Don't install stack by default in CI

.cirrus.yml

@@ -17,8 +17,6 @@ task:
     S3_HOST: ENCRYPTED[ce961780a33159f7d1d8046956b5ac6ebc3bfc8149428e5f538576cda51d9f3d0c35b79cdd1e325793639ff6e31f889d]
   install_script: pkg install -y ghc hs-cabal-install git bash misc/compat10x misc/compat11x misc/compat12x gmake
   script:
-    - tzsetup Etc/GMT
-    - adjkerntz -a
     - bash .github/scripts/build.sh
     - bash .github/scripts/test.sh
   binaries_artifacts:

.github/scripts/common.sh

@@ -88,28 +88,28 @@ download_cabal_cache() {
 	case "${RUNNER_OS}" in
 		"Linux")
 			case "${ARCH}" in
-				"32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/i386-linux-cabal-cache
+				"32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/i386-linux-cabal-cache
 					;;
-				"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-linux-cabal-cache
+				"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-linux-cabal-cache
 					;;
-				"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/aarch64-linux-cabal-cache
+				"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/aarch64-linux-cabal-cache
 					;;
-				"ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/armv7-linux-cabal-cache
+				"ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/armv7-linux-cabal-cache
 					;;
 			esac
 			;;
 		"FreeBSD")
-			url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-portbld-freebsd-cabal-cache
+			url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-portbld-freebsd-cabal-cache
 			;;
 		"Windows")
 			exe=".exe"
-			url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-mingw64-cabal-cache
+			url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-mingw64-cabal-cache
 			;;
 		"macOS")
 			case "${ARCH}" in
-				"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/aarch64-apple-darwin-cabal-cache
+				"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/aarch64-apple-darwin-cabal-cache
 					;;
-				"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-apple-darwin-cabal-cache
+				"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-apple-darwin-cabal-cache
 					;;
 			esac
 			;;

app/ghcup/AnsiMain.hs

@@ -1,621 +0,0 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE MultiWayIf        #-}
-
-module AnsiMain where
-
-import           GHCup
-import           GHCup.Download
-import           GHCup.Errors
-import           GHCup.Prelude                  ( decUTF8Safe )
-import           GHCup.Prelude.File
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.Process
-import           GHCup.Prompts
-import           GHCup.Types             hiding ( LeanAppState(..) )
-import           GHCup.Types.Optics             ( getDirs )
-import           GHCup.Utils
-
-import           Data.List (sort, intersperse)
-import           Data.Versions (prettyPVP, prettyVer)
-import           Codec.Archive
-import           Control.Monad.IO.Class
--- import           System.Console.ANSI
-import           System.Console.ANSI
-import           Terminal.Game
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
-
-import           Control.Exception.Safe
-import           Control.Monad                  ( when, forM_ )
-import           Control.Monad.ST
-import           Control.Monad.Reader           ( ReaderT(runReaderT), MonadReader, ask, lift )
-import           Control.Monad.Trans.Except
-import           Control.Monad.Trans.Resource
-import           Data.Functor
-import           Data.STRef
-import           Data.IORef
-import           Data.Maybe                     ( fromMaybe, catMaybes )
-import qualified Data.Text                     as Tx
-import qualified Data.Tuple                    as T
-import qualified Data.Vector                   as V
-import           GHC.IO                         ( unsafePerformIO )
-import           Haskus.Utils.Variant.Excepts
-import           System.Exit
-import           System.Environment (getExecutablePath)
-import qualified Data.Text                     as T
-import qualified Data.Text.Lazy.Builder        as B
-import qualified Data.Text.Lazy                as L
-import           System.FilePath
-import           URI.ByteString (serializeURIRef')
-
-
-
-data Direction = Up
-               | Down
-  deriving (Show, Eq)
-
-data BrickData = BrickData
-  { lr :: [ListResult]
-  }
-  deriving Show
-
-data BrickSettings = BrickSettings
-  { showAllVersions :: Bool
-  , showAllTools    :: Bool
-  }
-  deriving Show
-
-data BrickInternalState = BrickInternalState
-  { clr :: V.Vector ListResult
-  , ix  :: Int
-  }
-  deriving Show
-
-data BrickState = BrickState
-  { appData      :: BrickData
-  , appSettings  :: BrickSettings
-  , appState     :: BrickInternalState
-  , appKeys      :: KeyBindings
-  , appQuit      :: Bool
-  , appRestart   :: Bool
-  , appMoreInput :: Maybe String
-  }
-  deriving Show
-
-
-startGame :: BrickState -> IO BrickState
-startGame g = do
-  g'@BrickState { appRestart } <- errorPress $ playGameT liftIO (ghcupGame g)
-  if appRestart
-  then do
-    putStrLn "Press enter to continue"
-    _ <- getLine
-    startGame $ g' { appRestart = False }
-  else pure g'
-
-ansiMain :: AppState -> IO ()
-ansiMain s = do
-  writeIORef settings' s
-
-  eAppData <- getAppData (Just $ ghcupInfo s)
-  case eAppData of
-    Right ad -> do
-      let g = BrickState ad
-                         defaultAppSettings
-                         (constructList ad defaultAppSettings Nothing)
-                         (keyBindings (s :: AppState))
-                         False
-                         False
-                         Nothing
-
-
-      sizeCheck
-      void $ startGame g
-      cleanAndExit
-    Left e -> do
-      flip runReaderT s $ logError $ "Error building app state: " <> Tx.pack
-        (show e)
-      exitWith $ ExitFailure 2
-
-
- where
-  sizeCheck :: IO ()
-  sizeCheck = let (w, h) = T.swap . snd $ boundaries in assertTermDims w h
-
-
-ghcupGame :: BrickState -> Game BrickState
-ghcupGame bs = Game 13
-                    bs                                    -- ticks per second
-                    (\ge s e -> logicFun ge s e)          -- logic function
-                    (\r s -> centerFull r $ drawFun s r)  -- draw function
-                    (\s -> appQuit s || appRestart s)  -- quit function
-
-
-drawFun :: BrickState -> GEnv -> Plane
-drawFun (BrickState {..}) GEnv{..} =
-  let focus pl = maybe pl
-                   (\ix -> V.update pl (V.singleton (ix + 1, fmap invert $ pl V.! (ix + 1))))
-                   mix
-      rows = V.fromList [header, [box (mw - 2) 1 '=']] V.++ renderItems
-      cols = V.foldr (\xs ys -> zipWith (:) xs ys) (repeat []) $ V.filter ((==5) . length) rows
-      padded  = focus $ V.map (\xs -> zipWith padTo xs lengths) rows
-      lengths :: [Int]
-      lengths = fmap (maximum . fmap (fst . planeSize)) cols
-  in blankPlane mw mh
-    & (1, 1)   % box 1        1        'X' -- '┌'
-    & (2, 1)   % box 1        (mh - 3) '|' -- '│'
-    & (1, 2)   % box (mw - 2) 1        '=' -- '─'
-    & (2, mw)  % box 1        (mh - 3) '|' -- '│'
-    & (1, mw)  % box 1        1        'X' -- '┐'
-    & (mh-1, 2)  % box (mw - 2) 1      '=' -- '─'
-    & (mh-1, 1)  % box 1        1      'X' -- '└'
-    & (mh-1, mw) % box 1        1      'X' -- '┘'
-    & (2, 2)   % box (mw - 2) (mh - 3) ' ' -- ' '
-    & (2, 2)   % vcat (hcat <$> V.toList padded)
-    & (mh, 1)  % footer
-    & (1, mw `div` 2 - 2) % stringPlane "GHCup"
- where
-
-  padTo :: Plane -> Int -> Plane
-  padTo plane x =
-    let lstr = fst $ planeSize plane
-        add' = x - lstr + 1
-    in  if add' < 0 then plane else plane ||| stringPlane (replicate add' ' ')
-  mh :: Height
-  mw :: Width
-  (mh, mw) = T.swap eTermDims
-  footer = hcat
-         . intersperse (stringPlane "  ")
-         . fmap stringPlane
-         $ ["q:Quit", "i:Install", "u:Uninstall", "s:Set", "c:Changelog", "a:all versions", "↑:Up", "↓:Down"]
-  header = fmap stringPlane [" ", "Tool", "Version", "Tags", "Notes"]
-  (renderItems, mix) = drawListElements renderItem appState
-  renderItem _ _ listResult@ListResult{..} =
-    let marks = if
-          | lSet       -> color Green Vivid $ stringPlane "IS"
-          | lInstalled -> color Green Vivid $ stringPlane "I "
-          | otherwise  -> color Red Vivid $ stringPlane "X "
-        ver = case lCross of
-          Nothing -> stringPlane . Tx.unpack . prettyVer $ lVer
-          Just c  -> stringPlane . Tx.unpack $ (c <> "-" <> prettyVer lVer)
-        tool = printTool lTool
-        tag = let l = catMaybes . fmap printTag $ sort lTag
-              in  if null l then blankPlane 1 1 else foldr1 (\x y -> x ||| stringPlane "," ||| y) l
-        notes = let n = printNotes listResult
-                in  if null n
-                      then blankPlane 1 1
-                      else foldr1 (\x y -> x ||| stringPlane "," ||| y) n
-
-    in [marks ||| space, tool, ver, tag, notes]
-
-  printTag Recommended    = Just $ color Green Dull $ stringPlane "recommended"
-  printTag Latest         = Just $ color Yellow Dull $ stringPlane "latest"
-  printTag Prerelease     = Just $ color Red Dull $ stringPlane "prerelease"
-  printTag (Base pvp'')   = Just $ stringPlane ("base-" ++ T.unpack (prettyPVP pvp''))
-  printTag Old            = Nothing
-  printTag (UnknownTag t) = Just $ stringPlane t
-
-  printTool Cabal = stringPlane "cabal"
-  printTool GHC   = stringPlane "GHC"
-  printTool GHCup = stringPlane "GHCup"
-  printTool HLS   = stringPlane "HLS"
-  printTool Stack = stringPlane "Stack"
-
-  printNotes ListResult {..} =
-    (if hlsPowered then [color Green Dull $ stringPlane "hls-powered"] else mempty
-      )
-      ++ (if fromSrc then [color Blue Dull $ stringPlane "compiled"] else mempty)
-      ++ (if lStray then [color Blue Dull $ stringPlane "stray"] else mempty)
-
-  space = stringPlane " "
-
-  -- | Draws the list elements.
-  --
-  -- Evaluates the underlying container up to, and a bit beyond, the
-  -- selected element. The exact amount depends on available height
-  -- for drawing and 'listItemHeight'. At most, it will evaluate up to
-  -- element @(i + h + 1)@ where @i@ is the selected index and @h@ is the
-  -- available height.
-  drawListElements :: (Int -> Bool -> ListResult -> [Plane])
-                   -> BrickInternalState
-                   -> (V.Vector [Plane], Maybe Int)
-  drawListElements drawElem is@(BrickInternalState clr _) =
-      let es = clr
-          listSelected        = fmap fst $ listSelectedElement' is
-
-          (drawnElements, selIx) = runST $ do
-            ref <- newSTRef (Nothing :: Maybe Int)
-            vec <- newSTRef (mempty :: V.Vector [Plane])
-            elem' <- newSTRef 0
-            void $ flip V.imapM es $ \i' e -> do
-              let isSelected  = Just i' == listSelected
-                  elemWidget  = drawElem i' isSelected e
-              case es V.!? (i' - 1) of
-                    Just e' | lTool e' /= lTool e -> do
-                      modifySTRef elem' (+2)
-                      i <- readSTRef elem'
-                      when isSelected $ writeSTRef ref (Just i)
-                      modifySTRef vec (`V.snoc` [hBorder])
-                      modifySTRef vec (`V.snoc` elemWidget)
-                      pure ()
-                    _ -> do
-                      modifySTRef elem' (+1)
-                      i <- readSTRef elem'
-                      when isSelected $ writeSTRef ref (Just i)
-                      modifySTRef vec (`V.snoc` elemWidget)
-                      pure ()
-            i <- readSTRef ref
-            arr <- readSTRef vec
-            pure (arr, i)
-        in (makeVisible drawnElements (mh - 5) selIx, selIx)
-   where
-    makeVisible :: V.Vector [Plane] -> Height -> Maybe Int -> V.Vector [Plane]
-    makeVisible listElements drawableHeight (Just ix) =
-      let listHeight = V.length listElements
-      in if | listHeight <= 0 -> listElements
-            | listHeight > drawableHeight ->
-              if | ix <= drawableHeight -> makeVisible (V.init listElements) drawableHeight (Just ix)
-                 | otherwise            -> makeVisible (V.tail listElements) drawableHeight (Just (ix - 1))
-            | otherwise -> listElements
-    makeVisible listElements _ Nothing = listElements
-
-    hBorder = box (mw - 2) 1 '='
-
-
-logicFun :: GEnv -> BrickState -> Event -> IO BrickState
-logicFun _ gs (KeyPress 'q') = pure gs { appQuit = True }
-logicFun _ gs@BrickState{appMoreInput = Nothing} (KeyPress '\ESC') = pure gs { appMoreInput = Just "\ESC" }
-logicFun _ gs@BrickState{appMoreInput = Just "\ESC"} (KeyPress '[') = pure gs { appMoreInput = Just "\ESC[" }
-logicFun _ gs@BrickState{appMoreInput = Just "\ESC[", appState = s'} (KeyPress 'A')
- = pure gs { appMoreInput = Nothing, appState = moveCursor 1 s' Up }
-logicFun _ gs@BrickState{appMoreInput = Just "\ESC[", appState = s'} (KeyPress 'B')
- = pure gs { appMoreInput = Nothing, appState = moveCursor 1 s' Down }
-logicFun _ gs@BrickState{appMoreInput = Just _} _ = pure gs { appMoreInput = Nothing }
-logicFun _ gs (KeyPress 'i') = do
-  bs <- withIOAction install' gs
-  pure bs { appRestart = True }
-logicFun _ gs (KeyPress 'u') = do
-  bs <- withIOAction del' gs
-  pure bs { appRestart = True }
-logicFun _ gs (KeyPress 's') = do
-  bs <- withIOAction set' gs
-  pure bs { appRestart = True }
-logicFun _ gs (KeyPress 'c') = do
-  bs <- withIOAction changelog' gs
-  pure bs { appRestart = True }
-logicFun _ gs (KeyPress 'a') = pure $ hideShowHandler (not . showAllVersions) showAllTools gs
- where
-  hideShowHandler :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> BrickState -> BrickState
-  hideShowHandler f p BrickState{..} =
-    let newAppSettings   = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
-        newInternalState = constructList appData newAppSettings (Just appState)
-    in  BrickState appData newAppSettings newInternalState appKeys appQuit appRestart appMoreInput
-
--- windows powershell
-logicFun _ gs@BrickState{ appState = s' } (KeyPress 'P') = pure gs { appMoreInput = Nothing, appState = moveCursor 1 s' Down }
-logicFun _ gs@BrickState{ appState = s' } (KeyPress 'H') = pure gs { appMoreInput = Nothing, appState = moveCursor 1 s' Up }
-
-logicFun _ gs Tick           = pure gs
-logicFun _ gs (KeyPress _)   = pure gs
-
-withIOAction :: (BrickState
-                 -> (Int, ListResult)
-                 -> ReaderT AppState IO (Either String a))
-             -> BrickState
-             -> IO BrickState
-withIOAction action as = case listSelectedElement' (appState as) of
-  Nothing      -> pure as
-  Just (ix, e) -> do
-    clearScreen
-
-    settings <- readIORef settings'
-    flip runReaderT settings $ action as (ix, e) >>= \case
-      Left  err -> liftIO $ putStrLn ("Error: " <> err)
-      Right _   -> liftIO $ putStrLn "Success"
-    getAppData Nothing >>= \case
-      Right data' -> do
-        pure (updateList data' as)
-      Left err -> throwIO $ userError err
-
-moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
-moveCursor steps ais@BrickInternalState{..} direction =
-  let newIx = if direction == Down then ix + steps else ix - steps
-  in  case clr V.!? newIx of
-        Just _  -> BrickInternalState { ix = newIx, .. }
-        Nothing -> ais
-
-defaultAppSettings :: BrickSettings
-defaultAppSettings =
-  BrickSettings { showAllVersions = False, showAllTools = False }
-
--- | Update app data and list internal state based on new evidence.
--- This synchronises @BrickInternalState@ with @BrickData@
--- and @BrickSettings@.
-updateList :: BrickData -> BrickState -> BrickState
-updateList appD BrickState{..} =
-  let newInternalState = constructList appD appSettings (Just appState)
-  in  BrickState { appState    = newInternalState
-                 , appData     = appD
-                 , appSettings = appSettings
-                 , appKeys     = appKeys
-                 , appQuit     = appQuit
-                 , appRestart  = appRestart
-                 , appMoreInput = appMoreInput
-                 }
-
-constructList
-  :: BrickData
-  -> BrickSettings
-  -> Maybe BrickInternalState
-  -> BrickInternalState
-constructList appD appSettings = replaceLR
-  (filterVisible (showAllVersions appSettings) (showAllTools appSettings))
-  (lr appD)
-
-
--- | Replace the @appState@ or construct it based on a filter function
--- and a new @[ListResult]@ evidence.
--- When passed an existing @appState@, tries to keep the selected element.
-replaceLR
-  :: (ListResult -> Bool)
-  -> [ListResult]
-  -> Maybe BrickInternalState
-  -> BrickInternalState
-replaceLR filterF lr s =
-  let oldElem = s >>= listSelectedElement'
-      newVec  = V.fromList . filter filterF $ lr
-      newSelected =
-        case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of
-          Just ix -> ix
-          Nothing -> selectLatest newVec
-  in  BrickInternalState newVec newSelected
- where
-  toolEqual e1 e2 =
-    lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
-
-
-filterVisible :: Bool -> Bool -> ListResult -> Bool
-filterVisible v t e
-  | lInstalled e                   = True
-  | v, not t, lTool e `notElem` hiddenTools = True
-  | not v, t, Old `notElem` lTag e = True
-  | v, t                           = True
-  | otherwise = (Old `notElem` lTag e) && (lTool e `notElem` hiddenTools)
-
-
-hiddenTools :: [Tool]
-hiddenTools = []
-
-
-selectLatest :: V.Vector ListResult -> Int
-selectLatest = fromMaybe 0
-  . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
-
-
-listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
-listSelectedElement' BrickInternalState {..} = fmap (ix, ) $ clr V.!? ix
-
-
-boundaries :: (Coords, Coords)
-boundaries = ((1, 1), (24, 80))
-
-install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
-         => BrickState
-         -> (Int, ListResult)
-         -> m (Either String ())
-install' _ (_, ListResult {..}) = do
-  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-
-  let run =
-        runResourceT
-          . runE
-            @'[ AlreadyInstalled
-              , ArchiveResult
-              , UnknownArchive
-              , FileDoesNotExistError
-              , CopyError
-              , NoDownload
-              , NotInstalled
-              , BuildFailed
-              , TagNotFound
-              , DigestError
-              , ContentLengthError
-              , GPGError
-              , DownloadFailed
-              , DirNotEmpty
-              , NoUpdate
-              , TarDirDoesNotExist
-              , FileAlreadyExistsError
-              , ProcessError
-              , ToolShadowed
-              , UninstallFailed
-              , MergeFileTreeError
-              ]
-
-  run (do
-      ce <- liftIO $ fmap (either (const Nothing) Just) $
-        try @_ @SomeException $ getExecutablePath >>= canonicalizePath
-      dirs <- lift getDirs
-      case lTool of
-        GHC   -> do
-          let vi = getVersionInfo lVer GHC dls
-          liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce)
-        Cabal -> do
-          let vi = getVersionInfo lVer Cabal dls
-          liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
-        GHCup -> do
-          let vi = snd <$> getLatest dls GHCup
-          liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
-        HLS   -> do
-          let vi = getVersionInfo lVer HLS dls
-          liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
-        Stack -> do
-          let vi = getVersionInfo lVer Stack dls
-          liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
-    )
-    >>= \case
-          VRight (vi, Dirs{..}, Just ce) -> do
-            forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
-            case lTool of
-              GHCup -> do
-                up <- liftIO $ fmap (either (const Nothing) Just)
-                  $ try @_ @SomeException $ canonicalizePath (binDir </> "ghcup" <.> exeExt)
-                when ((normalise <$> up) == Just (normalise ce)) $
-                  -- TODO: track cli arguments of previous invocation
-                  void $ liftIO $ exec ce ["tui"] Nothing Nothing
-                logInfo "Please restart 'ghcup' for the changes to take effect"
-              _ -> pure ()
-            pure $ Right ()
-          VRight (vi, _, _) -> do
-            forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
-            logInfo "Please restart 'ghcup' for the changes to take effect"
-            pure $ Right ()
-          VLeft  (V (AlreadyInstalled _ _)) -> pure $ Right ()
-          VLeft (V NoUpdate) -> pure $ Right ()
-          VLeft e -> pure $ Left $ prettyShow e <> "\n"
-            <> "Also check the logs in ~/.ghcup/logs"
-
-
-set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
-     => BrickState
-     -> (Int, ListResult)
-     -> m (Either String ())
-set' bs input@(_, ListResult {..}) = do
-  settings <- liftIO $ readIORef settings'
-
-  let run =
-        flip runReaderT settings
-          . runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
-
-  run (do
-      case lTool of
-        GHC   -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> ()
-        Cabal -> liftE $ setCabal lVer $> ()
-        HLS   -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
-        Stack -> liftE $ setStack lVer $> ()
-        GHCup -> pure ()
-    )
-    >>= \case
-          VRight _ -> pure $ Right ()
-          VLeft  e -> case e of
-            (V (NotInstalled tool _)) -> do
-              promptAnswer <- getUserPromptResponse userPrompt
-              case promptAnswer of
-                PromptYes -> do
-                  res <- install' bs input
-                  case res of
-                    (Left err) -> pure $ Left err
-                    (Right _) -> do
-                      logInfo "Setting now..."
-                      set' bs input
-
-                PromptNo -> pure $ Left (prettyShow e)
-              where
-                userPrompt = L.toStrict . B.toLazyText . B.fromString $
-                  "This Version of "
-                  <> show tool
-                  <> " you are trying to set is not installed.\n"
-                  <> "Would you like to install it first? [Y/N]: "
-
-            _ -> pure $ Left (prettyShow e)
-
-
-
-del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
-     => BrickState
-     -> (Int, ListResult)
-     -> m (Either String ())
-del' _ (_, ListResult {..}) = do
-  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-
-  let run = runE @'[NotInstalled, UninstallFailed]
-
-  run (do
-      let vi = getVersionInfo lVer lTool dls
-      case lTool of
-        GHC   -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
-        Cabal -> liftE $ rmCabalVer lVer $> vi
-        HLS   -> liftE $ rmHLSVer lVer $> vi
-        Stack -> liftE $ rmStackVer lVer $> vi
-        GHCup -> pure Nothing
-    )
-    >>= \case
-          VRight vi -> do
-            forM_ (_viPostRemove =<< vi) $ \msg ->
-              logInfo msg
-            pure $ Right ()
-          VLeft  e -> pure $ Left (prettyShow e)
-
-
-changelog' :: (MonadReader AppState m, MonadIO m)
-           => BrickState
-           -> (Int, ListResult)
-           -> m (Either String ())
-changelog' _ (_, ListResult {..}) = do
-  AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-  case getChangeLog dls lTool (Left lVer) of
-    Nothing -> pure $ Left $
-      "Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
-    Just uri -> do
-      let cmd = case _rPlatform pfreq of
-            Darwin  -> "open"
-            Linux _ -> "xdg-open"
-            FreeBSD -> "xdg-open"
-            Windows -> "start"
-      exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
-        Right _ -> pure $ Right ()
-        Left  e -> pure $ Left $ prettyShow e
-
-
-settings' :: IORef AppState
-{-# NOINLINE settings' #-}
-settings' = unsafePerformIO $ do
-  dirs <- getAllDirs
-  let loggerConfig = LoggerConfig { lcPrintDebug  = False
-                                  , consoleOutter = \_ -> pure ()
-                                  , fileOutter    = \_ -> pure ()
-                                  , fancyColors   = True
-                                  }
-  newIORef $ AppState defaultSettings
-                      dirs
-                      defaultKeyBindings
-                      (GHCupInfo mempty mempty mempty)
-                      (PlatformRequest A_64 Darwin Nothing)
-                      loggerConfig
-
-
-getAppData :: Maybe GHCupInfo -> IO (Either String BrickData)
-getAppData mgi = runExceptT $ do
-  r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
-  liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
-  settings <- liftIO $ readIORef settings'
-
-  flip runReaderT settings $ do
-    lV <- listVersions Nothing Nothing
-    pure $ BrickData (reverse lV)
-
-
-getGHCupInfo :: IO (Either String GHCupInfo)
-getGHCupInfo = do
-  settings <- readIORef settings'
-
-  r        <-
-    flip runReaderT settings
-    . runE
-      @'[ DigestError
-        , ContentLengthError
-        , GPGError
-        , JSONError
-        , DownloadFailed
-        , FileDoesNotExistError
-        ]
-    $ liftE getDownloadsF
-
-  case r of
-    VRight a -> pure $ Right a
-    VLeft  e -> pure $ Left (prettyShow e)
-
-

app/ghcup/BrickMain.hs

@@ -487,7 +487,7 @@ install' _ (_, ListResult {..}) = do
             pure $ Right ()
           VLeft  (V (AlreadyInstalled _ _)) -> pure $ Right ()
           VLeft (V NoUpdate) -> pure $ Right ()
-          VLeft e -> pure $ Left $ prettyHFError e <> "\n"
+          VLeft e -> pure $ Left $ prettyShow e <> "\n"
             <> "Also check the logs in ~/.ghcup/logs"
 
 
@@ -524,7 +524,7 @@ set' bs input@(_, ListResult {..}) = do
                       logInfo "Setting now..."
                       set' bs input
 
-                PromptNo -> pure $ Left (prettyHFError e)
+                PromptNo -> pure $ Left (prettyShow e)
               where
                 userPrompt = L.toStrict . B.toLazyText . B.fromString $
                   "This Version of "
@@ -532,7 +532,7 @@ set' bs input@(_, ListResult {..}) = do
                   <> " you are trying to set is not installed.\n"
                   <> "Would you like to install it first? [Y/N]: "
 
-            _ -> pure $ Left (prettyHFError e)
+            _ -> pure $ Left (prettyShow e)
 
 
 
@@ -560,7 +560,7 @@ del' _ (_, ListResult {..}) = do
             forM_ (_viPostRemove =<< vi) $ \msg ->
               logInfo msg
             pure $ Right ()
-          VLeft  e -> pure $ Left (prettyHFError e)
+          VLeft  e -> pure $ Left (prettyShow e)
 
 
 changelog' :: (MonadReader AppState m, MonadIO m)
@@ -580,7 +580,7 @@ changelog' _ (_, ListResult {..}) = do
             Windows -> "start"
       exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
         Right _ -> pure $ Right ()
-        Left  e -> pure $ Left $ prettyHFError e
+        Left  e -> pure $ Left $ prettyShow e
 
 
 settings' :: IORef AppState
@@ -638,7 +638,7 @@ getGHCupInfo = do
 
   case r of
     VRight a -> pure $ Right a
-    VLeft  e -> pure $ Left (prettyHFError e)
+    VLeft  e -> pure $ Left (prettyShow e)
 
 
 getAppData :: Maybe GHCupInfo

app/ghcup/GHCup/OptParse.hs

@@ -104,14 +104,10 @@ data Command
   | Nuke
 #if defined(BRICK)
   | Interactive
-#endif
-#if defined(ANSI)
-  | InteractiveAnsi
 #endif
   | Prefetch PrefetchCommand
   | GC GCOptions
   | Run RunOptions
-  | PrintAppErrors
 
 
 
@@ -187,19 +183,8 @@ opts =
 com :: Parser Command
 com =
   subparser
-#if defined(ANSI)
-      (  command
-          "tui-ansi"
-          (   (\_ -> InteractiveAnsi)
-          <$> info
-                helper
-                (  progDesc "Start the interactive GHCup UI (ansi)"
-                )
-          )
-          <>
-#endif
 #if defined(BRICK)
-        command
+      (  command
           "tui"
           (   (\_ -> Interactive)
           <$> info
@@ -209,7 +194,7 @@ com =
           )
       <>  command
 #else
-          command
+      (  command
 #endif
           "install"
           (   Install
@@ -356,10 +341,3 @@ com =
            <> commandGroup "Nuclear Commands:"
            <> hidden
           )
-     <|> subparser
-          (command
-              "print-app-errors"
-               (info (pure PrintAppErrors <**> helper)
-                     (progDesc ""))
-           <> internal
-          )

app/ghcup/GHCup/OptParse/ChangeLog.hs

@@ -12,7 +12,6 @@ module GHCup.OptParse.ChangeLog where
 
 
 import           GHCup.Types
-import           GHCup.Errors
 import           GHCup.OptParse.Common
 import           GHCup.Prelude
 import           GHCup.Prelude.Logger
@@ -149,6 +148,6 @@ changelog ChangeLogOptions{..} runAppState runLogger = do
                  Nothing
               >>= \case
                     Right _ -> pure ExitSuccess
-                    Left  e -> logError (T.pack $ prettyHFError e)
+                    Left  e -> logError (T.pack $ prettyShow e)
                       >> pure (ExitFailure 13)
         else liftIO $ putStrLn uri' >> pure ExitSuccess

app/ghcup/GHCup/OptParse/Compile.hs

@@ -40,6 +40,7 @@ import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import           URI.ByteString          hiding ( uriParser )
 import qualified Data.Text                     as T
@@ -545,14 +546,14 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                 pure ExitSuccess
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
-                  Never -> runLogger $ logError $ T.pack $ prettyHFError err
+                  Never -> runLogger $ logError $ T.pack $ prettyShow err
-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
+                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
                         "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
                         <> T.pack tmpdir <> " for more clues." <> "\n" <>
                         "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 9
               VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                 pure $ ExitFailure 9
     (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
       runLogger $ logError "Hadrian cross compile support is not yet implemented!"
@@ -607,12 +608,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                 pure $ ExitFailure 3
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
-                  Never -> runLogger $ logError $ T.pack $ prettyHFError err
+                  Never -> runLogger $ logError $ T.pack $ prettyShow err
-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
+                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
                         "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
                         <> T.pack tmpdir <> " for more clues." <> "\n" <>
                         "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 9
               VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                 pure $ ExitFailure 9

app/ghcup/GHCup/OptParse/Config.hs

@@ -59,7 +59,7 @@ data ConfigCommand
     --[ Parsers ]--
     ---------------
 
-
+          
 configP :: Parser ConfigCommand
 configP = subparser
       (  command "init" initP
@@ -133,7 +133,8 @@ updateSettings UserSettings{..} Settings{..} =
        noNetwork'  = fromMaybe noNetwork uNoNetwork
        gpgSetting' = fromMaybe gpgSetting uGPGSetting
        platformOverride' = uPlatformOverride <|> platformOverride
-   in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride'
+       mirrors' = fromMaybe mirrors uMirrors
+   in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride' mirrors'
 
 
 

app/ghcup/GHCup/OptParse/DInfo.hs

@@ -115,5 +115,5 @@ dinfo runAppState runLogger = do
             liftIO $ putStrLn $ prettyDebugInfo di
             pure ExitSuccess
           VLeft e -> do
-            runLogger $ logError $ T.pack $ prettyHFError e
+            runLogger $ logError $ T.pack $ prettyShow e
             pure $ ExitFailure 8

app/ghcup/GHCup/OptParse/GC.hs

@@ -27,6 +27,7 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -138,5 +139,5 @@ gc GCOptions{..} runAppState runLogger = runGC runAppState (do
             VRight _ -> do
                   pure ExitSuccess
             VLeft e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
               pure $ ExitFailure 27

app/ghcup/GHCup/OptParse/Install.hs

@@ -38,6 +38,7 @@ import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           URI.ByteString          hiding ( uriParser )
 
 import qualified Data.Text                     as T
@@ -350,10 +351,10 @@ install installCommand settings getAppState' runLogger = case installCommand of
                 pure ExitSuccess
 
               VLeft e@(V (AlreadyInstalled _ _)) -> do
-                runLogger $ logWarn $ T.pack $ prettyHFError e
+                runLogger $ logWarn $ T.pack $ prettyShow e
                 pure ExitSuccess
               VLeft e@(V (AlreadyInstalled _ _)) -> do
-                runLogger $ logWarn $ T.pack $ prettyHFError e
+                runLogger $ logWarn $ T.pack $ prettyShow e
                 pure ExitSuccess
 
               VLeft (V (DirNotEmpty fp)) -> do
@@ -367,22 +368,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
 
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
-                  Never -> runLogger (logError $ T.pack $ prettyHFError err)
+                  Never -> runLogger (logError $ T.pack $ prettyShow err)
-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
+                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
                     "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
                     "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 3
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
-                  Never -> runLogger (logError $ T.pack $ prettyHFError err)
+                  Never -> runLogger (logError $ T.pack $ prettyShow err)
-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
+                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
                     "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
                     "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 3
 
               VLeft e -> do
                 runLogger $ do
-                  logError $ T.pack $ prettyHFError e
+                  logError $ T.pack $ prettyShow e
                   logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
                 pure $ ExitFailure 3
 
@@ -417,14 +418,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
                 runLogger $ logInfo msg
               pure ExitSuccess
             VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
             VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
@@ -432,7 +433,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
               pure $ ExitFailure 3
             VLeft e -> do
               runLogger $ do
-                logError $ T.pack $ prettyHFError e
+                logError $ T.pack $ prettyShow e
                 logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
               pure $ ExitFailure 4
 
@@ -467,14 +468,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
                 runLogger $ logInfo msg
               pure ExitSuccess
             VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
             VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
@@ -482,7 +483,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
               pure $ ExitFailure 3
             VLeft e -> do
               runLogger $ do
-                logError $ T.pack $ prettyHFError e
+                logError $ T.pack $ prettyShow e
                 logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
               pure $ ExitFailure 4
 
@@ -516,14 +517,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
                 runLogger $ logInfo msg
               pure ExitSuccess
             VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
             VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
@@ -531,6 +532,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
               pure $ ExitFailure 3
             VLeft e -> do
               runLogger $ do
-                logError $ T.pack $ prettyHFError e
+                logError $ T.pack $ prettyShow e
                 logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
               pure $ ExitFailure 4

app/ghcup/GHCup/OptParse/List.hs

@@ -12,7 +12,6 @@ module GHCup.OptParse.List where
 
 import           GHCup
 import           GHCup.Prelude
-import           GHCup.Prelude.Ansi
 import           GHCup.Types
 import           GHCup.OptParse.Common
 
@@ -156,6 +155,89 @@ printListResult no_color raw lr = do
         add' = x - lstr
     in  if add' < 0 then str' else str' ++ replicate add' ' '
 
+  -- | Calculate the render width of a string, considering
+  -- wide characters (counted as double width), ANSI escape codes
+  -- (not counted), and line breaks (in a multi-line string, the longest
+  -- line determines the width).
+  strWidth :: String -> Int
+  strWidth =
+    maximum
+      . (0 :)
+      . map (foldr (\a b -> charWidth a + b) 0)
+      . lines
+      . stripAnsi
+
+  -- | Strip ANSI escape sequences from a string.
+  --
+  -- >>> stripAnsi "\ESC[31m-1\ESC[m"
+  -- "-1"
+  stripAnsi :: String -> String
+  stripAnsi s' =
+    case
+        MP.parseMaybe (many $ "" <$ MP.try ansi <|> pure <$> MP.anySingle) s'
+      of
+        Nothing -> error "Bad ansi escape"  -- PARTIAL: should not happen
+        Just xs -> concat xs
+   where
+      -- This parses lots of invalid ANSI escape codes, but that should be fine
+    ansi =
+      MPC.string "\ESC[" *> digitSemicolons *> suffix MP.<?> "ansi" :: MP.Parsec
+          Void
+          String
+          Char
+    digitSemicolons = MP.takeWhileP Nothing (\c -> isDigit c || c == ';')
+    suffix = MP.oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
+
+  -- | Get the designated render width of a character: 0 for a combining
+  -- character, 1 for a regular character, 2 for a wide character.
+  -- (Wide characters are rendered as exactly double width in apps and
+  -- fonts that support it.) (From Pandoc.)
+  charWidth :: Char -> Int
+  charWidth c = case c of
+    _ | c < '\x0300'                     -> 1
+      | c >= '\x0300' && c <= '\x036F'   -> 0
+      |  -- combining
+        c >= '\x0370' && c <= '\x10FC'   -> 1
+      | c >= '\x1100' && c <= '\x115F'   -> 2
+      | c >= '\x1160' && c <= '\x11A2'   -> 1
+      | c >= '\x11A3' && c <= '\x11A7'   -> 2
+      | c >= '\x11A8' && c <= '\x11F9'   -> 1
+      | c >= '\x11FA' && c <= '\x11FF'   -> 2
+      | c >= '\x1200' && c <= '\x2328'   -> 1
+      | c >= '\x2329' && c <= '\x232A'   -> 2
+      | c >= '\x232B' && c <= '\x2E31'   -> 1
+      | c >= '\x2E80' && c <= '\x303E'   -> 2
+      | c == '\x303F'                    -> 1
+      | c >= '\x3041' && c <= '\x3247'   -> 2
+      | c >= '\x3248' && c <= '\x324F'   -> 1
+      | -- ambiguous
+        c >= '\x3250' && c <= '\x4DBF'   -> 2
+      | c >= '\x4DC0' && c <= '\x4DFF'   -> 1
+      | c >= '\x4E00' && c <= '\xA4C6'   -> 2
+      | c >= '\xA4D0' && c <= '\xA95F'   -> 1
+      | c >= '\xA960' && c <= '\xA97C'   -> 2
+      | c >= '\xA980' && c <= '\xABF9'   -> 1
+      | c >= '\xAC00' && c <= '\xD7FB'   -> 2
+      | c >= '\xD800' && c <= '\xDFFF'   -> 1
+      | c >= '\xE000' && c <= '\xF8FF'   -> 1
+      | -- ambiguous
+        c >= '\xF900' && c <= '\xFAFF'   -> 2
+      | c >= '\xFB00' && c <= '\xFDFD'   -> 1
+      | c >= '\xFE00' && c <= '\xFE0F'   -> 1
+      | -- ambiguous
+        c >= '\xFE10' && c <= '\xFE19'   -> 2
+      | c >= '\xFE20' && c <= '\xFE26'   -> 1
+      | c >= '\xFE30' && c <= '\xFE6B'   -> 2
+      | c >= '\xFE70' && c <= '\xFEFF'   -> 1
+      | c >= '\xFF01' && c <= '\xFF60'   -> 2
+      | c >= '\xFF61' && c <= '\x16A38'  -> 1
+      | c >= '\x1B000' && c <= '\x1B001' -> 2
+      | c >= '\x1D000' && c <= '\x1F1FF' -> 1
+      | c >= '\x1F200' && c <= '\x1F251' -> 2
+      | c >= '\x1F300' && c <= '\x1F773' -> 1
+      | c >= '\x20000' && c <= '\x3FFFD' -> 2
+      | otherwise                        -> 1
+
 
 
 

app/ghcup/GHCup/OptParse/Nuke.hs

@@ -26,6 +26,7 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -94,5 +95,5 @@ nuke appState runLogger = do
                       pure ExitSuccess
 
                 VLeft e -> do
-                  runLogger $ logError $ T.pack $ prettyHFError e
+                  runLogger $ logError $ T.pack $ prettyShow e
                   pure $ ExitFailure 15

app/ghcup/GHCup/OptParse/Prefetch.hs

@@ -30,6 +30,7 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -215,5 +216,5 @@ prefetch prefetchCommand runAppState runLogger =
                 VRight _ -> do
                       pure ExitSuccess
                 VLeft e -> do
-                  runLogger $ logError $ T.pack $ prettyHFError e
+                  runLogger $ logError $ T.pack $ prettyShow e
                   pure $ ExitFailure 15

app/ghcup/GHCup/OptParse/Rm.hs

@@ -34,6 +34,7 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -178,7 +179,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
               postRmLog vi
               pure ExitSuccess
             VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
               pure $ ExitFailure 7
 
   rmCabal' tv =
@@ -193,7 +194,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
               postRmLog vi
               pure ExitSuccess
             VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
               pure $ ExitFailure 15
 
   rmHLS' tv =
@@ -208,7 +209,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
               postRmLog vi
               pure ExitSuccess
             VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
               pure $ ExitFailure 15
 
   rmStack' tv =
@@ -223,7 +224,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
               postRmLog vi
               pure ExitSuccess
             VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
               pure $ ExitFailure 15
 
   postRmLog vi =

app/ghcup/GHCup/OptParse/Run.hs

@@ -40,6 +40,7 @@ import           Prelude                 hiding ( appendFile )
 import           System.FilePath
 import           System.Environment
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Map.Strict               as Map
 import qualified Data.Text                     as T
@@ -265,11 +266,11 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                case r' of
                  VRight _ -> pure ExitSuccess
                  VLeft e -> do
-                   runLogger $ logError $ T.pack $ prettyHFError e
+                   runLogger $ logError $ T.pack $ prettyShow e
                    pure $ ExitFailure 28
 #endif
          VLeft e -> do
-           runLogger $ logError $ T.pack $ prettyHFError e
+           runLogger $ logError $ T.pack $ prettyShow e
            pure $ ExitFailure 27
 
   where

app/ghcup/GHCup/OptParse/Set.hs

@@ -35,6 +35,7 @@ import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Data.Bifunctor (second)
@@ -285,7 +286,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
                     "GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
               pure ExitSuccess
             VLeft e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
               pure $ ExitFailure 5
 
 
@@ -306,7 +307,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
                     "Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version"
               pure ExitSuccess
             VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
               pure $ ExitFailure 14
 
   setHLS' :: SetOptions
@@ -326,7 +327,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
                     "HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version"
               pure ExitSuccess
             VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
               pure $ ExitFailure 14
 
 
@@ -347,5 +348,5 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
                     "Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version"
               pure ExitSuccess
             VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
               pure $ ExitFailure 14

app/ghcup/GHCup/OptParse/ToolRequirements.hs

@@ -23,6 +23,7 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import qualified Data.Text.IO                  as T
@@ -117,5 +118,5 @@ toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements run
     >>= \case
           VRight _ -> pure ExitSuccess
           VLeft  e -> do
-            runLogger $ logError $ T.pack $ prettyHFError e
+            runLogger $ logError $ T.pack $ prettyShow e
             pure $ ExitFailure 12

app/ghcup/GHCup/OptParse/UnSet.hs

@@ -31,6 +31,7 @@ import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -188,7 +189,7 @@ unset unsetCommand runLeanAppState runLogger = case unsetCommand of
                 runLogger $ logInfo "GHC successfully unset"
                 pure ExitSuccess
               VLeft  e -> do
-                runLogger $ logError $ T.pack $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                 pure $ ExitFailure 14
   (UnsetCabal (UnsetOptions _)) -> do
     void $ runLeanAppState (VRight <$> unsetCabal)

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -28,6 +28,7 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -151,5 +152,5 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
         runLogger $ logWarn "No GHCup update available"
         pure ExitSuccess
       VLeft e -> do
-        runLogger $ logError $ T.pack $ prettyHFError e
+        runLogger $ logError $ T.pack $ prettyShow e
         pure $ ExitFailure 11

app/ghcup/GHCup/OptParse/Whereis.hs

@@ -34,6 +34,7 @@ import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Environment
 import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -287,7 +288,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                 liftIO $ putStr r
                 pure ExitSuccess
               VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                 pure $ ExitFailure 30
     (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
       runLeanWhereIs leanAppstate (do
@@ -301,7 +302,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                 liftIO $ putStr r
                 pure ExitSuccess
               VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                 pure $ ExitFailure 30
 
     (WhereisTool tool whereVer, WhereisOptions{..}) -> do
@@ -317,7 +318,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                 liftIO $ putStr r
                 pure ExitSuccess
               VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                 pure $ ExitFailure 30
 
     (WhereisBaseDir, _) -> do

app/ghcup/Main.hs

@@ -13,9 +13,6 @@ module Main where
 #if defined(BRICK)
 import           BrickMain                    ( brickMain )
 #endif
-#if defined(ANSI)
-import           AnsiMain                     ( ansiMain )
-#endif
 
 import qualified GHCup.GHC as GHC
 import qualified GHCup.HLS as HLS
@@ -92,6 +89,7 @@ toSettings options = do
          noNetwork   = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
          gpgSetting  = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
          platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
+         mirrors  = fromMaybe (Types.mirrors defaultSettings) uMirrors
      in (Settings {..}, keyBindings)
 #if defined(INTERNAL_DOWNLOADER)
    defaultDownloader = Internal
@@ -209,7 +207,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                                           VRight r -> pure r
                                           VLeft e -> do
                                             runLogger
-                                              (logError $ T.pack $ prettyHFError e)
+                                              (logError $ T.pack $ prettyShow e)
                                             exitWith (ExitFailure 2)
 
                 ghcupInfo <-
@@ -221,7 +219,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                           VRight r -> pure r
                           VLeft  e -> do
                             runLogger
-                              (logError $ T.pack $ prettyHFError e)
+                              (logError $ T.pack $ prettyShow e)
                             exitWith (ExitFailure 2)
                 let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
 
@@ -237,9 +235,6 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                   UnSet _ -> pure ()
 #if defined(BRICK)
                   Interactive -> pure ()
-#endif
-#if defined(ANSI)
-                  InteractiveAnsi -> pure ()
 #endif
                   -- check for new tools
                   _
@@ -272,7 +267,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                   VRight _ -> pure ()
                   VLeft e -> do
                     runLogger
-                      (logError $ T.pack $ prettyHFError e)
+                      (logError $ T.pack $ prettyShow e)
                     exitWith (ExitFailure 30)
                 pure s'
 
@@ -298,11 +293,6 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
             Interactive -> do
               s' <- appState
               liftIO $ brickMain s' >> pure ExitSuccess
-#endif
-#if defined(ANSI)
-            InteractiveAnsi -> do
-              s' <- appState
-              liftIO $ ansiMain s' >> pure ExitSuccess
 #endif
             Install installCommand     -> install installCommand settings appState runLogger
             InstallCabalLegacy iopts   -> install (Left (InstallCabal iopts)) settings appState runLogger
@@ -322,7 +312,6 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
             Prefetch pfCom             -> prefetch pfCom runAppState runLogger
             GC gcOpts                  -> gc gcOpts runAppState runLogger
             Run runCommand             -> run runCommand appState leanAppstate runLogger
-            PrintAppErrors             -> putStrLn allHFError >> pure ExitSuccess
 
           case res of
             ExitSuccess        -> pure ()

cabal.project

@@ -5,8 +5,7 @@ optional-packages: ./vendored/*/*.cabal
 optimization: 2
 
 package ghcup
-    tests: True
+    flags: +tui
-    flags: +tui-ansi
 
 source-repository-package
   type: git

data/config.yaml

@@ -92,3 +92,30 @@ url-source:
 #     tag: Linux
 #   version: '18.04'
 platform-override: null
+
+# Support for mirrors. Currently there are 3 hosts you can mirror:
+#   - github.com (for stack and some older HLS versions)
+#   - raw.githubusercontent.com (for the yaml metadata)
+#   - downloads.haskell.org (for everything else)
+#
+# E.g. when we have 'https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml'
+# and the following mirror config
+#
+#  "raw.githubusercontent.com":
+#    authority:
+#      host: "mirror.sjtu.edu.cn"
+#    pathPrefix: "ghcup/yaml"
+#
+# Then the resulting url will be 'https://mirror.sjtu.edu.cn/ghcup/yaml/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml'
+mirrors:
+  "github.com":
+    authority:
+      host: "mirror.sjtu.edu.cn"
+  "raw.githubusercontent.com":
+    authority:
+      host: "mirror.sjtu.edu.cn"
+    pathPrefix: "ghcup/yaml"
+  "downloads.haskell.org":
+    authority:
+      host: "mirror.sjtu.edu.cn"
+

docs/about.md

@@ -60,29 +60,6 @@ All you wanted to know about GHCup.
 3. handling cabal projects
 4. being a stack alternative
 
-## Distribution policies
-
-Like most Linux distros and other distribution channels, GHCup also
-follows certain policies. These are as follows:
-
-1. The end-user experience is our primary concern
-    - ghcup in CI systems as a use case is a first class citizen
-2. We strive to collaborate with all maintainers of all the tools we support and maintain a good relationship
-3. We may fix build system or other distribution bugs in upstream bindists
-    - these are always communicated upstream
-4. We may even patch source code of supported tools in very rare cases if that is required to ensure that the end-user experience does not break
-    - we'll first try to upstream any such required patch and request a new release to avoid downstream patching
-    - patches will be communicated to the maintainers either way and we'll strive to get their review
-    - they will also be communicated to the end-user
-    - they will be uploaded along with the bindist
-    - we will avoid maintaining long-running downstream patches (currently zero)
-5. We may add bindists for platforms that upstream does not support
-    - this is currently the case for GHC for e.g. Alpine and possibly FreeBSD in the future
-    - this is currently also the case for stack on darwin M1
-    - we don't guarantee for unofficial bindists that the test suite passes at the moment (this may change in the future)
-6. We GPG sign all the GHCup metadata as well as the unofficial bindists
-    - any trust issues relating to missing checksums or GPG signatures is a bug and given high priority
-
 ## How
 
 Installs a specified GHC version into `~/.ghcup/ghc/<ver>`, and places `ghc-<ver>` symlinks in `~/.ghcup/bin/`.
@@ -98,15 +75,15 @@ cabal-install/HLS/stack are installed in `~/.ghcup/bin/<tool>-<ver>` and have un
 ## Known users
 
 * CI:
-    - [Github actions/virtual-environments](https://github.com/actions/virtual-environments)
+	- [Github actions/virtual-environments](https://github.com/actions/virtual-environments)
-    - [Github haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
+	- [Github haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
-    - [haskell-ci](https://github.com/haskell-CI/haskell-ci)
+	- [haskell-ci](https://github.com/haskell-CI/haskell-ci)
 * mirrors:
-    - [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
+	- [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
 * tools:
-    - [vscode-haskell](https://github.com/haskell/vscode-haskell)
+	- [vscode-haskell](https://github.com/haskell/vscode-haskell)
-    - [nvim-lsp-installer](https://github.com/williamboman/nvim-lsp-installer)
+	- [nvim-lsp-installer](https://github.com/williamboman/nvim-lsp-installer)
-    - [vabal](https://github.com/Franciman/vabal)
+	- [vabal](https://github.com/Franciman/vabal)
 
 ## Known problems
 

ghcup.cabal

@@ -41,11 +41,6 @@ flag tui
   default:     False
   manual:      True
 
-flag tui-ansi
-  description: Build the ansi-terminal powered tui (ghcup tui-ansi).
-  default:     False
-  manual:      True
-
 flag internal-downloader
   description:
     Compile the internal downloader, which links against OpenSSL. This is disabled on windows.
@@ -70,7 +65,6 @@ library
     GHCup.List
     GHCup.Platform
     GHCup.Prelude
-    GHCup.Prelude.Ansi
     GHCup.Prelude.File
     GHCup.Prelude.File.Search
     GHCup.Prelude.Internal
@@ -130,7 +124,7 @@ library
     , directory             ^>=1.3.6.0
     , disk-free-space       ^>=0.1.0.1
     , exceptions            ^>=0.10
-    , filepath              ==1.4.2.1
+    , filepath              ^>=1.4.2.1
     , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  ^>=3.2.1
     , libarchive            ^>=3.0.3.0
@@ -257,7 +251,7 @@ executable ghcup
     , containers            ^>=0.6
     , deepseq               ^>=1.4
     , directory             ^>=1.3.6.0
-    , filepath              ==1.4.2.1
+    , filepath              ^>=1.4.2.1
     , ghcup
     , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  ^>=3.2.1
@@ -285,14 +279,6 @@ executable ghcup
   if flag(internal-downloader)
     cpp-options: -DINTERNAL_DOWNLOADER
 
-  if flag(tui-ansi)
-    cpp-options:   -DANSI
-    other-modules: AnsiMain
-    build-depends:
-      , ansi-terminal
-      , ansi-terminal-game
-      , transformers        ^>=0.5
-
   if (flag(tui) && !os(windows))
     cpp-options:   -DBRICK
     other-modules: BrickMain
@@ -341,7 +327,7 @@ test-suite ghcup-test
     , bytestring                >=0.10    && <0.12
     , containers                ^>=0.6
     , directory                 ^>=1.3.6.0
-    , filepath                  ==1.4.2.1
+    , filepath                  ^>=1.4.2.1
     , generic-arbitrary         >=0.1.0   && <0.2.1 || >=0.2.2 && <0.3
     , ghcup
     , hspec                     >=2.7.10  && <2.11

lib/GHCup.hs

@@ -78,6 +78,7 @@ import           Text.Regex.Posix
 
 import qualified Data.Text                     as T
 import qualified Streamly.Prelude              as S
+import Text.PrettyPrint.HughesPJClass (prettyShow)
 
 
 
@@ -327,7 +328,7 @@ upgradeGHCup mtarget force' fatal = do
     Just pa
       | fatal -> throwE (ToolShadowed GHCup pa destFile latestVer)
       | otherwise ->
-        lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed GHCup pa destFile latestVer)
+        lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHCup pa destFile latestVer)
 
   pure latestVer
 

lib/GHCup/Cabal.hs

@@ -50,6 +50,7 @@ import           System.FilePath
 import           System.IO.Error
 
 import qualified Data.Text                     as T
+import Text.PrettyPrint.HughesPJClass (prettyShow)
 
 
 
@@ -234,7 +235,7 @@ setCabal ver = do
 
   liftIO (isShadowed cabalbin) >>= \case
     Nothing -> pure ()
-    Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa cabalbin ver)
+    Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa cabalbin ver)
 
   pure ()
 

lib/GHCup/Download.hs

@@ -75,6 +75,7 @@ import           System.Exit
 import           System.FilePath
 import           System.IO.Error
 import           System.IO.Temp
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           URI.ByteString
 
 import qualified Crypto.Hash.SHA256            as SHA256
@@ -175,7 +176,7 @@ getBase uri = do
                                   Lax -> lift (warnCache (displayException e) downloader) >> pure Nothing)
                . catchE @_ @_ @'[DownloadFailed] (\e@(DownloadFailed _) -> case metaMode of
                    Strict -> throwE e
-                   Lax -> lift (warnCache (prettyHFError e) downloader) >> pure Nothing)
+                   Lax -> lift (warnCache (prettyShow e) downloader) >> pure Nothing)
                . fmap Just
                . smartDl
                $ uri
@@ -333,19 +334,21 @@ download :: ( MonadReader env m
          -> Maybe FilePath    -- ^ optional filename
          -> Bool              -- ^ whether to read an write etags
          -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
-download uri gpgUri eDigest eCSize dest mfn etags
+download rawUri gpgUri eDigest eCSize dest mfn etags
   | scheme == "https" = liftE dl
   | scheme == "http"  = liftE dl
   | scheme == "file"  = do
-      let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
+      let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri
       lift $ logDebug $ "using local file: " <> T.pack destFile'
       forM_ eDigest (liftE . flip checkDigest destFile')
       pure destFile'
   | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
 
  where
-  scheme = view (uriSchemeL' % schemeBSL') uri
+  scheme = view (uriSchemeL' % schemeBSL') rawUri
   dl = do
+    Settings{ mirrors } <- lift getSettings
+    let uri = applyMirrors mirrors rawUri
     baseDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri mfn
     lift $ logInfo $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri <> " as file " <> T.pack baseDestFile
 
@@ -391,7 +394,7 @@ download uri gpgUri eDigest eCSize dest mfn etags
                   liftE $ flip onException
                        (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile))
                    $ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
-                        (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e))
+                        (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyShow (GPGError e))
                         ) $ do
                       o' <- liftIO getGpgOpts
                       lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
@@ -485,10 +488,7 @@ download uri gpgUri eDigest eCSize dest mfn etags
                  , MonadMask m
                  , MonadIO m
                  )
-              => [String]
+              => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
-              -> FilePath
-              -> URI
-              -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
   wgetEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
     let destFileTemp = tmpFile destFile
     flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
@@ -751,3 +751,17 @@ getLastHeader = T.unlines . lastDef [] . filter (\x -> not (null x)) . splitOn [
 
 tmpFile :: FilePath -> FilePath
 tmpFile = (<.> "tmp")
+
+
+applyMirrors :: DownloadMirrors -> URI -> URI
+applyMirrors (DM ms) uri@(URI { uriAuthority = Just (Authority { authorityHost = Host host }) }) =
+  case M.lookup (decUTF8Safe host) ms of
+    Nothing -> uri
+    Just (DownloadMirror auth (Just prefix)) ->
+      uri { uriAuthority = Just auth
+          , uriPath = E.encodeUtf8 $ T.pack ("/" <> T.unpack prefix <> (T.unpack . decUTF8Safe . uriPath $ uri))
+          }
+    Just (DownloadMirror auth Nothing) ->
+      uri { uriAuthority = Just auth }
+applyMirrors _ uri = uri
+

lib/GHCup/Errors.hs

@@ -6,7 +6,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeOperators           #-}
 {-# LANGUAGE FlexibleInstances           #-}
-{-# LANGUAGE RankNTypes           #-}
 
 {-|
 Module      : GHCup.Errors
@@ -35,150 +34,9 @@ import           URI.ByteString
 
 import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
-import           Data.Data (Proxy(..))
 
 
 
-allHFError :: String
-allHFError = unlines allErrors
- where
-  format p = "GHCup-" <> show (eBase p) <> " " <>  eDesc p
-  format'' e p = "GHCup-" <> show (eNum e) <> " " <>  eDesc p
-  format' e  _ = "GHCup-" <> show (eNum e) <> " " <>  prettyShow e
-  format''' e  _ str' = "GHCup-" <> show (eNum e) <> " " <>  str'
-  allErrors =
-    [ "# low level errors (1 to 500)"
-    , let proxy = Proxy :: Proxy NoCompatiblePlatform in format proxy
-    , let proxy = Proxy :: Proxy NoDownload in format proxy
-    , let proxy = Proxy :: Proxy NoUpdate in format proxy
-    , let proxy = Proxy :: Proxy DistroNotFound in format proxy
-    , let proxy = Proxy :: Proxy UnknownArchive in format proxy
-    , let proxy = Proxy :: Proxy UnsupportedScheme in format proxy
-    , let proxy = Proxy :: Proxy CopyError in format proxy
-    , let proxy = Proxy :: Proxy MergeFileTreeError in format proxy
-    , let proxy = Proxy :: Proxy TagNotFound in format proxy
-    , let proxy = Proxy :: Proxy NextVerNotFound in format proxy
-    , let proxy = Proxy :: Proxy AlreadyInstalled in format proxy
-    , let proxy = Proxy :: Proxy DirNotEmpty in format proxy
-    , let proxy = Proxy :: Proxy NotInstalled in format proxy
-    , let proxy = Proxy :: Proxy UninstallFailed in format proxy
-    , let proxy = Proxy :: Proxy NotFoundInPATH in format proxy
-    , let proxy = Proxy :: Proxy JSONError in format proxy
-    , let proxy = Proxy :: Proxy FileDoesNotExistError in format proxy
-    , let proxy = Proxy :: Proxy FileAlreadyExistsError in format proxy
-    , let proxy = Proxy :: Proxy TarDirDoesNotExist in format proxy
-    , let proxy = Proxy :: Proxy DigestError in format proxy
-    , let proxy = Proxy :: Proxy GPGError in format proxy
-    , let proxy = Proxy :: Proxy HTTPStatusError in format proxy
-    , let proxy = Proxy :: Proxy MalformedHeaders in format proxy
-    , let proxy = Proxy :: Proxy HTTPNotModified in format proxy
-    , let proxy = Proxy :: Proxy NoLocationHeader in format proxy
-    , let proxy = Proxy :: Proxy TooManyRedirs in format proxy
-    , let proxy = Proxy :: Proxy PatchFailed in format proxy
-    , let proxy = Proxy :: Proxy NoToolRequirements in format proxy
-    , let proxy = Proxy :: Proxy InvalidBuildConfig in format proxy
-    , let proxy = Proxy :: Proxy NoToolVersionSet in format proxy
-    , let proxy = Proxy :: Proxy NoNetwork in format proxy
-    , let proxy = Proxy :: Proxy HadrianNotFound in format proxy
-    , let proxy = Proxy :: Proxy ToolShadowed in format proxy
-    , let proxy = Proxy :: Proxy ContentLengthError in format proxy
-    , ""
-    , "# high level errors (5000+)"
-    , let proxy = Proxy :: Proxy DownloadFailed in format proxy
-    , let proxy = Proxy :: Proxy InstallSetError in format proxy
-    , let proxy = Proxy :: Proxy BuildFailed in format proxy
-    , let proxy = Proxy :: Proxy GHCupSetError in format proxy
-    , ""
-    , "# true exceptions (500+)"
-    , let proxy = Proxy :: Proxy ParseError in format proxy
-    , let proxy = Proxy :: Proxy UnexpectedListLength in format proxy
-    , let proxy = Proxy :: Proxy NoUrlBase in format proxy
-    , ""
-    , "# orphans (800+)"
-    , let proxy = Proxy :: Proxy URIParseError in format proxy
-    , let proxy = Proxy :: Proxy URIParseError
-          e     = MalformedScheme MissingColon
-      in format' e proxy
-    , let proxy = Proxy :: Proxy URIParseError
-          e     = MalformedUserInfo
-      in format' e proxy
-    , let proxy = Proxy :: Proxy URIParseError
-          e     = MalformedQuery
-      in format' e proxy
-    , let proxy = Proxy :: Proxy URIParseError
-          e     = MalformedFragment
-      in format' e proxy
-    , let proxy = Proxy :: Proxy URIParseError
-          e     = MalformedHost
-      in format' e proxy
-    , let proxy = Proxy :: Proxy URIParseError
-          e     = MalformedPort
-      in format' e proxy
-    , let proxy = Proxy :: Proxy URIParseError
-          e     = MalformedPath
-      in format' e proxy
-    , let proxy = Proxy :: Proxy URIParseError
-          e     = OtherError ""
-      in format'' e proxy
-    , let proxy = Proxy :: Proxy ArchiveResult in format proxy
-    , let proxy = Proxy :: Proxy ArchiveResult
-          e     = ArchiveFatal
-      in format' e proxy
-    , let proxy = Proxy :: Proxy ArchiveResult
-          e     = ArchiveFailed
-      in format' e proxy
-    , let proxy = Proxy :: Proxy ArchiveResult
-          e     = ArchiveWarn
-      in format' e proxy
-    , let proxy = Proxy :: Proxy ArchiveResult
-          e     = ArchiveRetry
-      in format' e proxy
-    , let proxy = Proxy :: Proxy ArchiveResult
-          e     = ArchiveOk
-      in format' e proxy
-    , let proxy = Proxy :: Proxy ArchiveResult
-          e     = ArchiveEOF
-      in format' e proxy
-
-    , let proxy = Proxy :: Proxy ProcessError in format proxy
-    , let proxy = Proxy :: Proxy ProcessError
-          e     = NonZeroExit 0 "" []
-      in format''' e proxy "A process returned a non-zero exit code."
-    , let proxy = Proxy :: Proxy ProcessError
-          e     = PTerminated "" []
-      in format''' e proxy "A process terminated prematurely."
-    , let proxy = Proxy :: Proxy ProcessError
-          e     = PStopped "" []
-      in format''' e proxy "A process stopped prematurely."
-    , let proxy = Proxy :: Proxy ProcessError
-          e     = NoSuchPid "" []
-      in format''' e proxy "Could not find PID for this process."
-    ]
-
-
-prettyHFError :: (Pretty e, HFErrorProject e) => e -> String
-prettyHFError e =
-  let errorCode = "GHCup-" <> padIntAndShow (eNum e)
-  in ("[" <> linkEscapeCode errorCode  (hfErrorLink errorCode) <> "] ") <> prettyShow e
- where
-  linkEscapeCode linkText link = "\ESC]8;;" <> link <> "\ESC\\" <> linkText <> "\ESC]8;;\ESC\\"
-  hfErrorLink errorCode = "https://errors.haskell.org/messages/" <> errorCode
-  padIntAndShow i
-    | i < 10    = "0000" <> show i
-    | i < 100   = "000"  <> show i
-    | i < 1000  = "00"   <> show i
-    | i < 10000 = "0"    <> show i
-    | otherwise =           show i
-
-class HFErrorProject a where
-  eNum :: a -> Int
-  eNum _ = eBase (Proxy :: Proxy a)
-
-  eBase :: Proxy a -> Int
-
-  eDesc :: Proxy a -> String
-
-
     ------------------------
     --[ Low-level errors ]--
     ------------------------
@@ -193,32 +51,20 @@ instance Pretty NoCompatiblePlatform where
   pPrint (NoCompatiblePlatform str') =
     text ("Could not find a compatible platform. Got: " ++ str')
 
-instance HFErrorProject NoCompatiblePlatform where
-  eBase _ = 1
-  eDesc _ = "No compatible platform could be found"
-
 -- | Unable to find a download for the requested version/distro.
 data NoDownload = NoDownload
   deriving Show
 
 instance Pretty NoDownload where
   pPrint NoDownload =
-    text (eDesc (Proxy :: Proxy NoDownload))
+    text "Unable to find a download for the requested version/distro."
-
-instance HFErrorProject NoDownload where
-  eBase _ = 10
-  eDesc _ = "Unable to find a download for the requested version/distro."
 
 -- | No update available or necessary.
 data NoUpdate = NoUpdate
   deriving Show
 
 instance Pretty NoUpdate where
-  pPrint NoUpdate = text (eDesc (Proxy :: Proxy NoUpdate))
+  pPrint NoUpdate = text "No update available or necessary."
-
-instance HFErrorProject NoUpdate where
-  eBase _ = 20
-  eDesc _ = "No update available or necessary."
 
 -- | The Architecture is unknown and unsupported.
 data NoCompatibleArch = NoCompatibleArch String
@@ -228,21 +74,13 @@ instance Pretty NoCompatibleArch where
   pPrint (NoCompatibleArch arch) =
     text ("The Architecture is unknown or unsupported. Got: " ++ arch)
 
-instance HFErrorProject NoCompatibleArch where
-  eBase _ = 30
-  eDesc _ = "The Architecture is unknown and unsupported"
-
 -- | Unable to figure out the distribution of the host.
 data DistroNotFound = DistroNotFound
   deriving Show
 
 instance Pretty DistroNotFound where
   pPrint DistroNotFound =
-    text (eDesc (Proxy :: Proxy DistroNotFound))
+    text "Unable to figure out the distribution of the host."
-
-instance HFErrorProject DistroNotFound where
-  eBase _ = 40
-  eDesc _ = "Unable to figure out the distribution of the host"
 
 -- | The archive format is unknown. We don't know how to extract it.
 data UnknownArchive = UnknownArchive FilePath
@@ -252,21 +90,12 @@ instance Pretty UnknownArchive where
   pPrint (UnknownArchive file) =
     text $ "The archive format is unknown. We don't know how to extract the file " <> file
 
-instance HFErrorProject UnknownArchive where
-  eBase _ = 50
-  eDesc _ = "The archive format is unknown. We don't know how to extract it."
-
 -- | The scheme is not supported (such as ftp).
 data UnsupportedScheme = UnsupportedScheme
   deriving Show
 
 instance Pretty UnsupportedScheme where
-  pPrint UnsupportedScheme =
+  pPrint UnsupportedScheme = text "The scheme is not supported (such as ftp)."
-    text (eDesc (Proxy :: Proxy UnsupportedScheme))
-
-instance HFErrorProject UnsupportedScheme where
-  eBase _ = 60
-  eDesc _ = "The scheme is not supported (such as ftp)."
 
 -- | Unable to copy a file.
 data CopyError = CopyError String
@@ -276,10 +105,6 @@ instance Pretty CopyError where
   pPrint (CopyError reason) =
     text ("Unable to copy a file. Reason was: " ++ reason)
 
-instance HFErrorProject CopyError where
-  eBase _ = 70
-  eDesc _ = "Unable to copy a file."
-
 -- | Unable to merge file trees.
 data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath
   deriving Show
@@ -289,10 +114,6 @@ instance Pretty MergeFileTreeError where
     text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e)
      <+> text "\n...you may need to delete" <+> text to <+> text "manually. Make sure it's gone."
 
-instance HFErrorProject MergeFileTreeError where
-  eBase _ = 80
-  eDesc _ = "Unable to merge file trees during installation"
-
 -- | Unable to find a tag of a tool.
 data TagNotFound = TagNotFound Tag Tool
   deriving Show
@@ -301,10 +122,6 @@ instance Pretty TagNotFound where
   pPrint (TagNotFound tag tool) =
     text "Unable to find tag" <+> pPrint tag <+> text "of tool" <+> pPrint tool
 
-instance HFErrorProject TagNotFound where
-  eBase _ = 90
-  eDesc _ = "Unable to find a tag of a tool"
-
 -- | Unable to find the next version of a tool (the one after the currently
 -- set one).
 data NextVerNotFound = NextVerNotFound Tool
@@ -314,10 +131,6 @@ instance Pretty NextVerNotFound where
   pPrint (NextVerNotFound tool) =
     text "Unable to find next (the one after the currently set one) version of tool" <+> pPrint tool
 
-instance HFErrorProject NextVerNotFound where
-  eBase _ = 100
-  eDesc _ = "Unable to find the next version of a tool (the one after the currently set one)"
-
 -- | The tool (such as GHC) is already installed with that version.
 data AlreadyInstalled = AlreadyInstalled Tool Version
   deriving Show
@@ -327,9 +140,6 @@ instance Pretty AlreadyInstalled where
     (pPrint tool <> text "-" <> pPrint ver') <+> text "is already installed;"
     <+> text "if you really want to reinstall it, you may want to run 'ghcup install" <+> pPrint tool <+> text "--force" <+> (pPrint ver' <> text "'")
 
-instance HFErrorProject AlreadyInstalled where
-  eBase _ = 110
-  eDesc _ = "The tool (such as GHC) is already installed with that version"
 
 -- | The Directory is supposed to be empty, but wasn't.
 data DirNotEmpty = DirNotEmpty {path :: FilePath}
@@ -339,10 +149,6 @@ instance Pretty DirNotEmpty where
   pPrint (DirNotEmpty path) = do
     text $ "The directory was expected to be empty, but isn't: " <> path
 
-instance HFErrorProject DirNotEmpty where
-  eBase _ = 120
-  eDesc _ = "The Directory is supposed to be empty, but wasn't"
-
 -- | The tool is not installed. Some operations rely on a tool
 -- to be installed (such as setting the current GHC version).
 data NotInstalled = NotInstalled Tool GHCTargetVersion
@@ -352,10 +158,6 @@ instance Pretty NotInstalled where
   pPrint (NotInstalled tool ver) =
     text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
 
-instance HFErrorProject NotInstalled where
-  eBase _ = 130
-  eDesc _ = "The required tool is not installed"
-
 data UninstallFailed = UninstallFailed FilePath [FilePath]
   deriving Show
 
@@ -363,10 +165,6 @@ instance Pretty UninstallFailed where
   pPrint (UninstallFailed dir files) =
     text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually."
 
-instance HFErrorProject UninstallFailed where
-  eBase _ = 140
-  eDesc _ = "Uninstallation failed with leftover files"
-
 -- | An executable was expected to be in PATH, but was not found.
 data NotFoundInPATH = NotFoundInPATH FilePath
   deriving Show
@@ -377,10 +175,6 @@ instance Pretty NotFoundInPATH where
   pPrint (NotFoundInPATH exe) =
     text $ "The exe " <> exe <> " was not found in PATH."
 
-instance HFErrorProject NotFoundInPATH where
-  eBase _ = 150
-  eDesc _ = "An executable was expected to be in PATH, but was not found"
-
 -- | JSON decoding failed.
 data JSONError = JSONDecodeError String
   deriving Show
@@ -389,10 +183,6 @@ instance Pretty JSONError where
   pPrint (JSONDecodeError err) =
     text $ "JSON decoding failed with: " <> err
 
-instance HFErrorProject JSONError where
-  eBase _ = 160
-  eDesc _ = "JSON decoding failed"
-
 -- | A file that is supposed to exist does not exist
 -- (e.g. when we use file scheme to "download" something).
 data FileDoesNotExistError = FileDoesNotExistError FilePath
@@ -402,10 +192,6 @@ instance Pretty FileDoesNotExistError where
   pPrint (FileDoesNotExistError file) =
     text $ "File " <> file <> " does not exist."
 
-instance HFErrorProject FileDoesNotExistError where
-  eBase _ = 170
-  eDesc _ = "A file that is supposed to exist does not exist (oops)"
-
 -- | The file already exists
 -- (e.g. when we use isolated installs with the same path).
 -- (e.g. This is done to prevent any overwriting)
@@ -416,10 +202,6 @@ instance Pretty FileAlreadyExistsError where
   pPrint (FileAlreadyExistsError file) =
     text $ "File " <> file <> " Already exists."
 
-instance HFErrorProject FileAlreadyExistsError where
-  eBase _ = 180
-  eDesc _ = "A file already exists that wasn't expected to exist"
-
 data TarDirDoesNotExist = TarDirDoesNotExist TarDir
   deriving Show
 
@@ -427,10 +209,6 @@ instance Pretty TarDirDoesNotExist where
   pPrint (TarDirDoesNotExist dir) =
     text "Tar directory does not exist:" <+> pPrint dir
 
-instance HFErrorProject TarDirDoesNotExist where
-  eBase _ = 190
-  eDesc _ = "The tar directory (e.g. inside an archive) does not exist"
-
 -- | File digest verification failed.
 data DigestError = DigestError FilePath Text Text
   deriving Show
@@ -441,175 +219,6 @@ instance Pretty DigestError where
       <+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest <+> text
       "\nConsider removing the file in case it's cached and try again."
 
-instance HFErrorProject DigestError where
-  eBase _ = 200
-  eDesc _ = "File digest verification failed"
-
--- | File PGP verification failed.
-data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)
-
-deriving instance Show GPGError
-
-instance Pretty GPGError where
-  pPrint (GPGError reason) = text "GPG verify failed:" <+> pPrint reason
-
-instance HFErrorProject GPGError where
-  eBase _ = 210
-  eDesc _ = "File PGP verification failed"
-
--- | Unexpected HTTP status.
-data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
-  deriving Show
-
-instance Pretty HTTPStatusError where
-  pPrint (HTTPStatusError status _) =
-    text "Unexpected HTTP status:" <+> pPrint status
-
-instance HFErrorProject HTTPStatusError where
-  eBase _ = 220
-  eDesc _ = "Unexpected HTTP status error (e.g. during downloads)"
-
--- | Malformed headers.
-data MalformedHeaders = MalformedHeaders Text
-  deriving Show
-
-instance Pretty MalformedHeaders where
-  pPrint (MalformedHeaders h) =
-    text "Headers are malformed: " <+> pPrint h
-
-instance HFErrorProject MalformedHeaders where
-  eBase _ = 230
-  eDesc _ = "Malformed headers during download"
-
--- | Unexpected HTTP status.
-data HTTPNotModified = HTTPNotModified Text
-  deriving Show
-
-instance Pretty HTTPNotModified where
-  pPrint (HTTPNotModified etag) =
-    text "Remote resource not modifed, etag was:" <+> pPrint etag
-
-instance HFErrorProject HTTPNotModified where
-  eBase _ = 240
-  eDesc _ = "Not modified HTTP status error (e.g. during downloads)."
-
--- | The 'Location' header was expected during a 3xx redirect, but not found.
-data NoLocationHeader = NoLocationHeader
-  deriving Show
-
-instance Pretty NoLocationHeader where
-  pPrint NoLocationHeader =
-    text (eDesc (Proxy :: Proxy NoLocationHeader))
-
-instance HFErrorProject NoLocationHeader where
-  eBase _ = 250
-  eDesc _ = "The 'Location' header was expected during a 3xx redirect, but not found."
-
--- | Too many redirects.
-data TooManyRedirs = TooManyRedirs
-  deriving Show
-
-instance Pretty TooManyRedirs where
-  pPrint TooManyRedirs =
-    text (eDesc (Proxy :: Proxy TooManyRedirs))
-
-instance HFErrorProject TooManyRedirs where
-  eBase _ = 260
-  eDesc _ = "Too many redirections."
-
--- | A patch could not be applied.
-data PatchFailed = PatchFailed
-  deriving Show
-
-instance Pretty PatchFailed where
-  pPrint PatchFailed =
-    text (eDesc (Proxy :: Proxy PatchFailed))
-
-instance HFErrorProject PatchFailed where
-  eBase _ = 270
-  eDesc _ = "A patch could not be applied."
-
--- | The tool requirements could not be found.
-data NoToolRequirements = NoToolRequirements
-  deriving Show
-
-instance Pretty NoToolRequirements where
-  pPrint NoToolRequirements =
-    text (eDesc (Proxy :: Proxy NoToolRequirements))
-
-instance HFErrorProject NoToolRequirements where
-  eBase _ = 280
-  eDesc _ = "The Tool requirements could not be found."
-
-data InvalidBuildConfig = InvalidBuildConfig Text
-  deriving Show
-
-instance Pretty InvalidBuildConfig where
-  pPrint (InvalidBuildConfig reason) =
-    text "The build config is invalid. Reason was:" <+> pPrint reason
-
-instance HFErrorProject InvalidBuildConfig where
-  eBase _ = 290
-  eDesc _ = "The build config is invalid."
-
-data NoToolVersionSet = NoToolVersionSet Tool
-  deriving Show
-
-instance Pretty NoToolVersionSet where
-  pPrint (NoToolVersionSet tool) =
-    text "No version is set for tool" <+> pPrint tool <+> text "."
-
-instance HFErrorProject NoToolVersionSet where
-  eBase _ = 300
-  eDesc _ = "No version is set for tool (but was expected)."
-
-data NoNetwork = NoNetwork
-  deriving Show
-
-instance Pretty NoNetwork where
-  pPrint NoNetwork =
-    text (eDesc (Proxy :: Proxy NoNetwork))
-
-instance HFErrorProject NoNetwork where
-  eBase _ = 310
-  eDesc _ = "A download was required or requested, but '--offline' was specified."
-
-data HadrianNotFound = HadrianNotFound
-  deriving Show
-
-instance Pretty HadrianNotFound where
-  pPrint HadrianNotFound =
-    text (eDesc (Proxy :: Proxy HadrianNotFound))
-
-instance HFErrorProject HadrianNotFound where
-  eBase _ = 320
-  eDesc _ = "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
-
-data ToolShadowed = ToolShadowed
-                       Tool
-                       FilePath  -- shadow binary
-                       FilePath  -- upgraded binary
-                       Version   -- upgraded version
-  deriving Show
-
-instance Pretty ToolShadowed where
-  pPrint (ToolShadowed tool sh up _) =
-    text (prettyShow tool
-         <> " is shadowed by "
-         <> sh
-         <> ".\nThe upgrade will not be in effect, unless you remove "
-         <> sh
-         <> "\nor make sure "
-         <> takeDirectory up
-         <> " comes before "
-         <> takeDirectory sh
-         <> " in PATH."
-         )
-
-instance HFErrorProject ToolShadowed where
-  eBase _ = 330
-  eDesc _ = "A tool is shadowed in PATH."
-
 -- | File content length verification failed.
 data ContentLengthError = ContentLengthError (Maybe FilePath) (Maybe Integer) Integer
   deriving Show
@@ -633,16 +242,125 @@ instance Pretty ContentLengthError where
 
 instance Exception ContentLengthError
 
-instance HFErrorProject ContentLengthError where
+-- | File digest verification failed.
-  eBase _ = 340
+data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)
-  eDesc _ = "File content length verification failed"
+
+deriving instance Show GPGError
+
+instance Pretty GPGError where
+  pPrint (GPGError reason) = text "GPG verify failed:" <+> pPrint reason
+
+-- | Unexpected HTTP status.
+data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
+  deriving Show
+
+instance Pretty HTTPStatusError where
+  pPrint (HTTPStatusError status _) =
+    text "Unexpected HTTP status:" <+> pPrint status
+
+-- | Malformed headers.
+data MalformedHeaders = MalformedHeaders Text
+  deriving Show
+
+instance Pretty MalformedHeaders where
+  pPrint (MalformedHeaders h) =
+    text "Headers are malformed: " <+> pPrint h
+
+-- | Unexpected HTTP status.
+data HTTPNotModified = HTTPNotModified Text
+  deriving Show
+
+instance Pretty HTTPNotModified where
+  pPrint (HTTPNotModified etag) =
+    text "Remote resource not modifed, etag was:" <+> pPrint etag
+
+-- | The 'Location' header was expected during a 3xx redirect, but not found.
+data NoLocationHeader = NoLocationHeader
+  deriving Show
+
+instance Pretty NoLocationHeader where
+  pPrint NoLocationHeader =
+    text "The 'Location' header was expected during a 3xx redirect, but not found."
+
+-- | Too many redirects.
+data TooManyRedirs = TooManyRedirs
+  deriving Show
+
+instance Pretty TooManyRedirs where
+  pPrint TooManyRedirs =
+    text "Too many redirections."
+
+-- | A patch could not be applied.
+data PatchFailed = PatchFailed
+  deriving Show
+
+instance Pretty PatchFailed where
+  pPrint PatchFailed =
+    text "A patch could not be applied."
+
+-- | The tool requirements could not be found.
+data NoToolRequirements = NoToolRequirements
+  deriving Show
+
+instance Pretty NoToolRequirements where
+  pPrint NoToolRequirements =
+    text "The Tool requirements could not be found."
+
+data InvalidBuildConfig = InvalidBuildConfig Text
+  deriving Show
+
+instance Pretty InvalidBuildConfig where
+  pPrint (InvalidBuildConfig reason) =
+    text "The build config is invalid. Reason was:" <+> pPrint reason
+
+data NoToolVersionSet = NoToolVersionSet Tool
+  deriving Show
+
+instance Pretty NoToolVersionSet where
+  pPrint (NoToolVersionSet tool) =
+    text "No version is set for tool" <+> pPrint tool <+> text "."
+
+data NoNetwork = NoNetwork
+  deriving Show
+
+instance Pretty NoNetwork where
+  pPrint NoNetwork =
+    text "A download was required or requested, but '--offline' was specified."
+
+data HadrianNotFound = HadrianNotFound
+  deriving Show
+
+instance Pretty HadrianNotFound where
+  pPrint HadrianNotFound =
+    text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
+
+data ToolShadowed = ToolShadowed
+                       Tool
+                       FilePath  -- shadow binary
+                       FilePath  -- upgraded binary
+                       Version   -- upgraded version
+  deriving Show
+
+instance Pretty ToolShadowed where
+  pPrint (ToolShadowed tool sh up _) =
+    text (prettyShow tool
+         <> " is shadowed by "
+         <> sh
+         <> ".\nThe upgrade will not be in effect, unless you remove "
+         <> sh
+         <> "\nor make sure "
+         <> takeDirectory up
+         <> " comes before "
+         <> takeDirectory sh
+         <> " in PATH."
+         )
 
     -------------------------
     --[ High-level errors ]--
     -------------------------
 
 -- | A download failed. The underlying error is encapsulated.
-data DownloadFailed = forall xs . (HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
+data DownloadFailed = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
 
 instance Pretty DownloadFailed where
   pPrint (DownloadFailed reason) =
@@ -652,12 +370,7 @@ instance Pretty DownloadFailed where
 
 deriving instance Show DownloadFailed
 
-instance HFErrorProject DownloadFailed where
+data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), Show (V xs2), Pretty (V xs2)) => InstallSetError (V xs1) (V xs2)
-  eBase _ = 5000
-  eNum (DownloadFailed xs) = 5000 + eNum xs
-  eDesc _ = "A download failed."
-
-data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), HFErrorProject (V xs1), Show (V xs2), Pretty (V xs2), HFErrorProject (V xs2)) => InstallSetError (V xs1) (V xs2)
 
 instance Pretty InstallSetError where
   pPrint (InstallSetError reason1 reason2) =
@@ -668,15 +381,9 @@ instance Pretty InstallSetError where
 
 deriving instance Show InstallSetError
 
-instance HFErrorProject InstallSetError where
-  eBase _ = 7000
-  -- will there be collisions?
-  eNum (InstallSetError xs1 xs2) = 7000 + eNum xs1 + eNum xs2
-  eDesc _ = "Installation or setting the tool failed."
-
 
 -- | A build failed.
-data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es), HFErrorProject (V es)) => BuildFailed FilePath (V es)
+data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
 
 instance Pretty BuildFailed where
   pPrint (BuildFailed path reason) =
@@ -686,28 +393,18 @@ instance Pretty BuildFailed where
 
 deriving instance Show BuildFailed
 
-instance HFErrorProject BuildFailed where
-  eBase _ = 8000
-  eNum (BuildFailed _ xs2) = 8000 + eNum xs2
-  eDesc _ = "The build failed."
-
 
 -- | Setting the current GHC version failed.
-data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es), HFErrorProject (V es)) => GHCupSetError (V es)
+data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es)) => GHCupSetError (V es)
 
 instance Pretty GHCupSetError where
   pPrint (GHCupSetError reason) =
     case reason of
       VMaybe (_ :: GHCupSetError) -> pPrint reason
-      _ -> text "Setting the current version failed:" <+> pPrint reason
+      _ -> text "Setting the current GHC version failed:" <+> pPrint reason
 
 deriving instance Show GHCupSetError
 
-instance HFErrorProject GHCupSetError where
-  eBase _ = 9000
-  eNum (GHCupSetError xs) = 9000 + eNum xs
-  eDesc _ = "Setting the current version failed."
-
 
     ---------------------------------------------
     --[ True Exceptions (e.g. for MonadThrow) ]--
@@ -724,10 +421,6 @@ instance Pretty ParseError where
 
 instance Exception ParseError
 
-instance HFErrorProject ParseError where
-  eBase _ = 500
-  eDesc _ = "A parse error occured."
-
 
 data UnexpectedListLength = UnexpectedListLength String
   deriving Show
@@ -738,10 +431,6 @@ instance Pretty UnexpectedListLength where
 
 instance Exception UnexpectedListLength
 
-instance HFErrorProject UnexpectedListLength where
-  eBase _ = 510
-  eDesc _ = "A list had an unexpected length."
-
 data NoUrlBase = NoUrlBase Text
   deriving Show
 
@@ -751,10 +440,6 @@ instance Pretty NoUrlBase where
 
 instance Exception NoUrlBase
 
-instance HFErrorProject NoUrlBase where
-  eBase _ = 520
-  eDesc _ = "URL does not have a base filename."
-
 
 
     ------------------------
@@ -774,23 +459,6 @@ instance
          Right x -> pPrint x
          Left xs -> pPrint xs
 
-instance HFErrorProject (V '[]) where
-   {-# INLINABLE eBase #-}
-   eBase _ = undefined
-   {-# INLINABLE eDesc #-}
-   eDesc _ = undefined
-
-instance
-   ( HFErrorProject x
-   , HFErrorProject (V xs)
-   ) => HFErrorProject (V (x ': xs))
-   where
-      eNum v = case popVariantHead v of
-         Right x -> eNum x
-         Left xs -> eNum xs
-      eDesc _ = undefined
-      eBase _ = undefined
-
 instance Pretty URIParseError where
   pPrint (MalformedScheme reason) =
     text "Failed to parse URI. Malformed scheme:" <+> text (show reason)
@@ -809,22 +477,6 @@ instance Pretty URIParseError where
   pPrint (OtherError err) =
     text "Failed to parse URI:" <+> pPrint err
 
-instance HFErrorProject URIParseError where
-  eBase _ = 800
-
-  eNum (MalformedScheme NonAlphaLeading) = 801
-  eNum (MalformedScheme InvalidChars) = 802
-  eNum (MalformedScheme MissingColon) = 803
-  eNum MalformedUserInfo   = 804
-  eNum MalformedQuery      = 805
-  eNum MalformedFragment   = 806
-  eNum MalformedHost       = 807
-  eNum MalformedPort       = 808
-  eNum MalformedPath       = 809
-  eNum (OtherError _)      = 810
-
-  eDesc _ = "Failed to parse URI."
-
 instance Pretty ArchiveResult where
   pPrint ArchiveFatal = text "Archive result: fatal"
   pPrint ArchiveFailed = text "Archive result: failed"
@@ -833,37 +485,5 @@ instance Pretty ArchiveResult where
   pPrint ArchiveOk = text "Archive result: Ok"
   pPrint ArchiveEOF = text "Archive result: EOF"
 
-instance HFErrorProject ArchiveResult where
-  eBase _ = 820
-
-  eNum ArchiveFatal  = 821
-  eNum ArchiveFailed = 822
-  eNum ArchiveWarn   = 823
-  eNum ArchiveRetry  = 824
-  eNum ArchiveOk     = 825
-  eNum ArchiveEOF    = 826
-
-  eDesc _ = "Archive extraction result."
-
 instance Pretty T.Text where
   pPrint = text . T.unpack
-
-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 "."
-
-instance HFErrorProject ProcessError where
-  eBase _ = 840
-
-  eNum NonZeroExit{}     = 841
-  eNum (PTerminated _ _) = 842
-  eNum (PStopped _ _)    = 843
-  eNum (NoSuchPid _ _)   = 844
-
-  eDesc _ = "A process exited prematurely."

lib/GHCup/GHC.hs

@@ -459,7 +459,7 @@ setGHC ver sghc mBinDir = do
       when (targetFile == "ghc") $
         liftIO (isShadowed fullF) >>= \case
           Nothing -> pure ()
-          Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed GHC pa fullF (_tvVersion ver))
+          Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHC pa fullF (_tvVersion ver))
 
   when (isNothing mBinDir) $ do
     -- create symlink for share dir

lib/GHCup/HLS.hs

@@ -68,6 +68,7 @@ import qualified Data.List.NonEmpty            as NE
 import qualified Data.ByteString               as B
 import qualified Data.Text                     as T
 import qualified Text.Megaparsec               as MP
+import Text.PrettyPrint.HughesPJClass (prettyShow)
 
 
 data HLSVer = SourceDist Version
@@ -633,7 +634,7 @@ setHLS ver shls mBinDir = do
 
       liftIO (isShadowed wrapper) >>= \case
         Nothing -> pure ()
-        Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed HLS pa wrapper ver)
+        Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed HLS pa wrapper ver)
 
 
 unsetHLS :: ( MonadMask m

lib/GHCup/Prelude.hs

@@ -41,26 +41,24 @@ import GHCup.Prelude.Posix
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Haskus.Utils.Variant.Excepts
-import           Text.PrettyPrint.HughesPJClass ( Pretty )
+import           Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
 import qualified Data.Text                     as T
 
 
 
 -- for some obscure reason... this won't type-check if we move it to a different module
 catchWarn :: forall es m env . ( Pretty (V es)
-                             , HFErrorProject (V es)
                              , MonadReader env m
                              , HasLog env
                              , MonadIO m
                              , Monad m) => Excepts es m () -> Excepts '[] m ()
-catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyHFError $ v))
+catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
 
 
 runBothE' :: forall e m a b .
              ( Monad m
              , Show (V e)
              , Pretty (V e)
-             , HFErrorProject (V e)
              , PopVariant InstallSetError e
              , LiftVariant' e (InstallSetError ': e)
              , e :<< (InstallSetError ': e)

lib/GHCup/Prelude/Ansi.hs

@@ -1,92 +0,0 @@
-module GHCup.Prelude.Ansi where
-
-import           Control.Applicative
-import           Data.Char
-import           Data.Void
-
-import qualified Text.Megaparsec               as MP
-import qualified Text.Megaparsec.Char          as MPC
-
-
--- | Calculate the render width of a string, considering
--- wide characters (counted as double width), ANSI escape codes
--- (not counted), and line breaks (in a multi-line string, the longest
--- line determines the width).
-strWidth :: String -> Int
-strWidth =
-  maximum
-    . (0 :)
-    . map (foldr (\a b -> charWidth a + b) 0)
-    . lines
-    . stripAnsi
-
--- | Strip ANSI escape sequences from a string.
---
--- >>> stripAnsi "\ESC[31m-1\ESC[m"
--- "-1"
-stripAnsi :: String -> String
-stripAnsi s' =
-  case
-      MP.parseMaybe (many $ "" <$ MP.try ansi <|> pure <$> MP.anySingle) s'
-    of
-      Nothing -> error "Bad ansi escape"  -- PARTIAL: should not happen
-      Just xs -> concat xs
- where
-    -- This parses lots of invalid ANSI escape codes, but that should be fine
-  ansi =
-    MPC.string "\ESC[" *> digitSemicolons *> suffix MP.<?> "ansi" :: MP.Parsec
-        Void
-        String
-        Char
-  digitSemicolons = MP.takeWhileP Nothing (\c -> isDigit c || c == ';')
-  suffix = MP.oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
-
--- | Get the designated render width of a character: 0 for a combining
--- character, 1 for a regular character, 2 for a wide character.
--- (Wide characters are rendered as exactly double width in apps and
--- fonts that support it.) (From Pandoc.)
-charWidth :: Char -> Int
-charWidth c = case c of
-  _ | c < '\x0300'                     -> 1
-    | c >= '\x0300' && c <= '\x036F'   -> 0
-    |  -- combining
-      c >= '\x0370' && c <= '\x10FC'   -> 1
-    | c >= '\x1100' && c <= '\x115F'   -> 2
-    | c >= '\x1160' && c <= '\x11A2'   -> 1
-    | c >= '\x11A3' && c <= '\x11A7'   -> 2
-    | c >= '\x11A8' && c <= '\x11F9'   -> 1
-    | c >= '\x11FA' && c <= '\x11FF'   -> 2
-    | c >= '\x1200' && c <= '\x2328'   -> 1
-    | c >= '\x2329' && c <= '\x232A'   -> 2
-    | c >= '\x232B' && c <= '\x2E31'   -> 1
-    | c >= '\x2E80' && c <= '\x303E'   -> 2
-    | c == '\x303F'                    -> 1
-    | c >= '\x3041' && c <= '\x3247'   -> 2
-    | c >= '\x3248' && c <= '\x324F'   -> 1
-    | -- ambiguous
-      c >= '\x3250' && c <= '\x4DBF'   -> 2
-    | c >= '\x4DC0' && c <= '\x4DFF'   -> 1
-    | c >= '\x4E00' && c <= '\xA4C6'   -> 2
-    | c >= '\xA4D0' && c <= '\xA95F'   -> 1
-    | c >= '\xA960' && c <= '\xA97C'   -> 2
-    | c >= '\xA980' && c <= '\xABF9'   -> 1
-    | c >= '\xAC00' && c <= '\xD7FB'   -> 2
-    | c >= '\xD800' && c <= '\xDFFF'   -> 1
-    | c >= '\xE000' && c <= '\xF8FF'   -> 1
-    | -- ambiguous
-      c >= '\xF900' && c <= '\xFAFF'   -> 2
-    | c >= '\xFB00' && c <= '\xFDFD'   -> 1
-    | c >= '\xFE00' && c <= '\xFE0F'   -> 1
-    | -- ambiguous
-      c >= '\xFE10' && c <= '\xFE19'   -> 2
-    | c >= '\xFE20' && c <= '\xFE26'   -> 1
-    | c >= '\xFE30' && c <= '\xFE6B'   -> 2
-    | c >= '\xFE70' && c <= '\xFEFF'   -> 1
-    | c >= '\xFF01' && c <= '\xFF60'   -> 2
-    | c >= '\xFF61' && c <= '\x16A38'  -> 1
-    | c >= '\x1B000' && c <= '\x1B001' -> 2
-    | c >= '\x1D000' && c <= '\x1F1FF' -> 1
-    | c >= '\x1F200' && c <= '\x1F251' -> 2
-    | c >= '\x1F300' && c <= '\x1F773' -> 1
-    | c >= '\x20000' && c <= '\x3FFFD' -> 2
-    | otherwise                        -> 1

lib/GHCup/Stack.hs

@@ -50,6 +50,7 @@ import           System.FilePath
 import           System.IO.Error
 
 import qualified Data.Text                     as T
+import Text.PrettyPrint.HughesPJClass (prettyShow)
 
 
 
@@ -233,7 +234,7 @@ setStack ver = do
 
   liftIO (isShadowed stackbin) >>= \case
     Nothing -> pure ()
-    Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa stackbin ver)
+    Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa stackbin ver)
 
   pure ()
 

lib/GHCup/Types.hs

@@ -35,7 +35,7 @@ import           Data.Text                      ( Text )
 import           Data.Versions
 import           GHC.IO.Exception               ( ExitCode )
 import           Optics                         ( makeLenses )
-import           Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
+import           Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text, (<+>))
 import           URI.ByteString
 #if defined(BRICK)
 import           Graphics.Vty                   ( Key(..) )
@@ -274,6 +274,23 @@ instance NFData DownloadInfo
     --[ Others ]--
     --------------
 
+data DownloadMirror = DownloadMirror {
+     authority :: Authority
+   , pathPrefix :: Maybe Text
+} deriving (Eq, Ord, GHC.Generic, Show)
+
+instance NFData DownloadMirror
+
+newtype DownloadMirrors = DM (Map Text DownloadMirror)
+  deriving (Eq, Ord, GHC.Generic, Show)
+
+instance NFData DownloadMirrors
+
+instance NFData UserInfo
+instance NFData Host
+instance NFData Port
+instance NFData Authority
+
 
 -- | How to descend into a tar archive.
 data TarDir = RealDir FilePath
@@ -316,12 +333,13 @@ data UserSettings = UserSettings
   , uUrlSource   :: Maybe URLSource
   , uNoNetwork   :: Maybe Bool
   , uGPGSetting  :: Maybe GPGSetting
-  , uPlatformOverride    :: Maybe PlatformRequest
+  , uPlatformOverride :: Maybe PlatformRequest
+  , uMirrors     :: Maybe DownloadMirrors
   }
   deriving (Show, GHC.Generic)
 
 defaultUserSettings :: UserSettings
-defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 
 fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
 fromSettings Settings{..} Nothing =
@@ -338,6 +356,7 @@ fromSettings Settings{..} Nothing =
     , uUrlSource = Just urlSource
     , uGPGSetting = Just gpgSetting
     , uPlatformOverride = platformOverride
+    , uMirrors = Just mirrors
   }
 fromSettings Settings{..} (Just KeyBindings{..}) =
   let ukb = UserKeyBindings
@@ -364,6 +383,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
     , uUrlSource = Just urlSource
     , uGPGSetting = Just gpgSetting
     , uPlatformOverride = platformOverride
+    , uMirrors = Just mirrors
   }
 
 data UserKeyBindings = UserKeyBindings
@@ -445,6 +465,7 @@ data Settings = Settings
   , gpgSetting       :: GPGSetting
   , noColor          :: Bool -- this also exists in LoggerConfig
   , platformOverride :: Maybe PlatformRequest
+  , mirrors          :: DownloadMirrors
   }
   deriving (Show, GHC.Generic)
 
@@ -452,7 +473,7 @@ defaultMetaCache :: Integer
 defaultMetaCache = 300 -- 5 minutes
 
 defaultSettings :: Settings
-defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing
+defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty)
 
 instance NFData Settings
 
@@ -632,7 +653,15 @@ data ProcessError = NonZeroExit Int 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

lib/GHCup/Types/JSON.hs

@@ -29,6 +29,7 @@ import           Control.Applicative            ( (<|>) )
 import           Data.Aeson              hiding (Key)
 import           Data.Aeson.TH
 import           Data.Aeson.Types        hiding (Key)
+import           Data.ByteString                ( ByteString )
 import           Data.List.NonEmpty             ( NonEmpty(..) )
 import           Data.Text.Encoding            as E
 import           Data.Versions
@@ -225,6 +226,12 @@ instance FromJSON VersionCmp where
       Right r -> pure r
       Left  e -> fail (MP.errorBundlePretty e)
 
+instance ToJSON ByteString where
+  toJSON = toJSON . E.decodeUtf8With E.lenientDecode
+
+instance FromJSON ByteString where
+  parseJSON = withText "ByteString" $ \t -> pure $ E.encodeUtf8 t
+
 versionCmpToText :: VersionCmp -> T.Text
 versionCmpToText (VR_gt   ver') = "> " <> prettyV ver'
 versionCmpToText (VR_gteq ver') = ">= " <> prettyV ver'
@@ -320,6 +327,12 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupI
 deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
 deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Host
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''UserInfo
+deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' (T.unpack . T.toLower) . T.stripPrefix (T.pack "authority") . T.pack $ str' } ''Authority
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirror
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirrors
 deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
 deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
 
@@ -356,4 +369,3 @@ instance FromJSON URLSource where
       pure (AddSource r)
 
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
-

lib/GHCup/Utils.hs

@@ -1301,7 +1301,7 @@ gitOut args dir = do
     ExitSuccess   -> pure $ T.pack $ stripNewlineEnd $ T.unpack $ decUTF8Safe' _stdOut
     ExitFailure c -> do
       let pe = NonZeroExit c "git" args
-      lift $ logDebug $ T.pack (prettyHFError pe)
+      lift $ logDebug $ T.pack (prettyShow pe)
       throwE pe
 
 processBranches :: T.Text -> [String]

stack.yaml

@@ -6,7 +6,6 @@ packages:
 extra-deps:
   - Cabal-3.6.2.0@sha256:e2266e14758c1f799220fad7f0d4b0b4ec567d81b7ba3faea17ff76d4c31de95,12437
   - IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
-  - ansi-terminal-game-1.8.0.0@sha256:001cf786098d9f1056ac6055ff3f598054b5c231b7343e76abb686d4f485855d,6977
   - ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
   - base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231
   - brick-0.64@sha256:f03fa14607c22cf48af99e24c44f79a0fb073f7ec229f15e969fed9ff73c93f6,16530
@@ -28,7 +27,6 @@ extra-deps:
   - http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
   - libarchive-3.0.3.0
   - libyaml-streamly-0.2.1
-  - linebreak-1.1.0.1@sha256:b253873c3f98189eb22a5a9f0405677cde125c09666b63c3117f497c01c95893,1397
   - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
   - optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
   - optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
@@ -38,10 +36,8 @@ extra-deps:
   - primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
   - regex-posix-clib-2.7
   - streamly-0.8.2@sha256:ec521b7c1c4db068501c35804af77f40b7d34232f5e29d9b99e722229040eb80,23500
-  - strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
-  - timers-tick-0.5.0.1@sha256:91d4b03266715c6969b82cb24e57a6b47191a4d2f95e9a92e0ad3f7301cc7c8b,1552
   - unicode-data-0.3.0@sha256:0545e079705a5381d0893f8fe8daaa08fc9174baeab269b9cf651817d8eadbc6,5123
-  - unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
+  - strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
   - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
   - yaml-streamly-0.12.1
 
@@ -64,9 +60,6 @@ flags:
   streamly:
     use-unliftio: true
 
-  ghcup:
-    tui-ansi: true
-
 ghc-options:
   "$locals": -O2
   streamly: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16

vendored/ansi-terminal-game-1.8.0.0/COPYING

@@ -1,674 +0,0 @@
-              GNU GENERAL PUBLIC LICENSE
-                Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-                     Preamble
-
-  The GNU General Public License is a free, copyleft license for
-software and other kinds of works.
-
-  The licenses for most software and other practical works are designed
-to take away your freedom to share and change the works.  By contrast,
-the GNU General Public License is intended to guarantee your freedom to
-share and change all versions of a program--to make sure it remains free
-software for all its users.  We, the Free Software Foundation, use the
-GNU General Public License for most of our software; it applies also to
-any other work released this way by its authors.  You can apply it to
-your programs, too.
-
-  When we speak of free software, we are referring to freedom, not
-price.  Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-them if you wish), that you receive source code or can get it if you
-want it, that you can change the software or use pieces of it in new
-free programs, and that you know you can do these things.
-
-  To protect your rights, we need to prevent others from denying you
-these rights or asking you to surrender the rights.  Therefore, you have
-certain responsibilities if you distribute copies of the software, or if
-you modify it: responsibilities to respect the freedom of others.
-
-  For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must pass on to the recipients the same
-freedoms that you received.  You must make sure that they, too, receive
-or can get the source code.  And you must show them these terms so they
-know their rights.
-
-  Developers that use the GNU GPL protect your rights with two steps:
-(1) assert copyright on the software, and (2) offer you this License
-giving you legal permission to copy, distribute and/or modify it.
-
-  For the developers' and authors' protection, the GPL clearly explains
-that there is no warranty for this free software.  For both users' and
-authors' sake, the GPL requires that modified versions be marked as
-changed, so that their problems will not be attributed erroneously to
-authors of previous versions.
-
-  Some devices are designed to deny users access to install or run
-modified versions of the software inside them, although the manufacturer
-can do so.  This is fundamentally incompatible with the aim of
-protecting users' freedom to change the software.  The systematic
-pattern of such abuse occurs in the area of products for individuals to
-use, which is precisely where it is most unacceptable.  Therefore, we
-have designed this version of the GPL to prohibit the practice for those
-products.  If such problems arise substantially in other domains, we
-stand ready to extend this provision to those domains in future versions
-of the GPL, as needed to protect the freedom of users.
-
-  Finally, every program is threatened constantly by software patents.
-States should not allow patents to restrict development and use of
-software on general-purpose computers, but in those that do, we wish to
-avoid the special danger that patents applied to a free program could
-make it effectively proprietary.  To prevent this, the GPL assures that
-patents cannot be used to render the program non-free.
-
-  The precise terms and conditions for copying, distribution and
-modification follow.
-
-                TERMS AND CONDITIONS
-
-  0. Definitions.
-
-  "This License" refers to version 3 of the GNU General Public License.
-
-  "Copyright" also means copyright-like laws that apply to other kinds of
-works, such as semiconductor masks.
-
-  "The Program" refers to any copyrightable work licensed under this
-License.  Each licensee is addressed as "you".  "Licensees" and
-"recipients" may be individuals or organizations.
-
-  To "modify" a work means to copy from or adapt all or part of the work
-in a fashion requiring copyright permission, other than the making of an
-exact copy.  The resulting work is called a "modified version" of the
-earlier work or a work "based on" the earlier work.
-
-  A "covered work" means either the unmodified Program or a work based
-on the Program.
-
-  To "propagate" a work means to do anything with it that, without
-permission, would make you directly or secondarily liable for
-infringement under applicable copyright law, except executing it on a
-computer or modifying a private copy.  Propagation includes copying,
-distribution (with or without modification), making available to the
-public, and in some countries other activities as well.
-
-  To "convey" a work means any kind of propagation that enables other
-parties to make or receive copies.  Mere interaction with a user through
-a computer network, with no transfer of a copy, is not conveying.
-
-  An interactive user interface displays "Appropriate Legal Notices"
-to the extent that it includes a convenient and prominently visible
-feature that (1) displays an appropriate copyright notice, and (2)
-tells the user that there is no warranty for the work (except to the
-extent that warranties are provided), that licensees may convey the
-work under this License, and how to view a copy of this License.  If
-the interface presents a list of user commands or options, such as a
-menu, a prominent item in the list meets this criterion.
-
-  1. Source Code.
-
-  The "source code" for a work means the preferred form of the work
-for making modifications to it.  "Object code" means any non-source
-form of a work.
-
-  A "Standard Interface" means an interface that either is an official
-standard defined by a recognized standards body, or, in the case of
-interfaces specified for a particular programming language, one that
-is widely used among developers working in that language.
-
-  The "System Libraries" of an executable work include anything, other
-than the work as a whole, that (a) is included in the normal form of
-packaging a Major Component, but which is not part of that Major
-Component, and (b) serves only to enable use of the work with that
-Major Component, or to implement a Standard Interface for which an
-implementation is available to the public in source code form.  A
-"Major Component", in this context, means a major essential component
-(kernel, window system, and so on) of the specific operating system
-(if any) on which the executable work runs, or a compiler used to
-produce the work, or an object code interpreter used to run it.
-
-  The "Corresponding Source" for a work in object code form means all
-the source code needed to generate, install, and (for an executable
-work) run the object code and to modify the work, including scripts to
-control those activities.  However, it does not include the work's
-System Libraries, or general-purpose tools or generally available free
-programs which are used unmodified in performing those activities but
-which are not part of the work.  For example, Corresponding Source
-includes interface definition files associated with source files for
-the work, and the source code for shared libraries and dynamically
-linked subprograms that the work is specifically designed to require,
-such as by intimate data communication or control flow between those
-subprograms and other parts of the work.
-
-  The Corresponding Source need not include anything that users
-can regenerate automatically from other parts of the Corresponding
-Source.
-
-  The Corresponding Source for a work in source code form is that
-same work.
-
-  2. Basic Permissions.
-
-  All rights granted under this License are granted for the term of
-copyright on the Program, and are irrevocable provided the stated
-conditions are met.  This License explicitly affirms your unlimited
-permission to run the unmodified Program.  The output from running a
-covered work is covered by this License only if the output, given its
-content, constitutes a covered work.  This License acknowledges your
-rights of fair use or other equivalent, as provided by copyright law.
-
-  You may make, run and propagate covered works that you do not
-convey, without conditions so long as your license otherwise remains
-in force.  You may convey covered works to others for the sole purpose
-of having them make modifications exclusively for you, or provide you
-with facilities for running those works, provided that you comply with
-the terms of this License in conveying all material for which you do
-not control copyright.  Those thus making or running the covered works
-for you must do so exclusively on your behalf, under your direction
-and control, on terms that prohibit them from making any copies of
-your copyrighted material outside their relationship with you.
-
-  Conveying under any other circumstances is permitted solely under
-the conditions stated below.  Sublicensing is not allowed; section 10
-makes it unnecessary.
-
-  3. Protecting Users' Legal Rights From Anti-Circumvention Law.
-
-  No covered work shall be deemed part of an effective technological
-measure under any applicable law fulfilling obligations under article
-11 of the WIPO copyright treaty adopted on 20 December 1996, or
-similar laws prohibiting or restricting circumvention of such
-measures.
-
-  When you convey a covered work, you waive any legal power to forbid
-circumvention of technological measures to the extent such circumvention
-is effected by exercising rights under this License with respect to
-the covered work, and you disclaim any intention to limit operation or
-modification of the work as a means of enforcing, against the work's
-users, your or third parties' legal rights to forbid circumvention of
-technological measures.
-
-  4. Conveying Verbatim Copies.
-
-  You may convey verbatim copies of the Program's source code as you
-receive it, in any medium, provided that you conspicuously and
-appropriately publish on each copy an appropriate copyright notice;
-keep intact all notices stating that this License and any
-non-permissive terms added in accord with section 7 apply to the code;
-keep intact all notices of the absence of any warranty; and give all
-recipients a copy of this License along with the Program.
-
-  You may charge any price or no price for each copy that you convey,
-and you may offer support or warranty protection for a fee.
-
-  5. Conveying Modified Source Versions.
-
-  You may convey a work based on the Program, or the modifications to
-produce it from the Program, in the form of source code under the
-terms of section 4, provided that you also meet all of these conditions:
-
-    a) The work must carry prominent notices stating that you modified
-    it, and giving a relevant date.
-
-    b) The work must carry prominent notices stating that it is
-    released under this License and any conditions added under section
-    7.  This requirement modifies the requirement in section 4 to
-    "keep intact all notices".
-
-    c) You must license the entire work, as a whole, under this
-    License to anyone who comes into possession of a copy.  This
-    License will therefore apply, along with any applicable section 7
-    additional terms, to the whole of the work, and all its parts,
-    regardless of how they are packaged.  This License gives no
-    permission to license the work in any other way, but it does not
-    invalidate such permission if you have separately received it.
-
-    d) If the work has interactive user interfaces, each must display
-    Appropriate Legal Notices; however, if the Program has interactive
-    interfaces that do not display Appropriate Legal Notices, your
-    work need not make them do so.
-
-  A compilation of a covered work with other separate and independent
-works, which are not by their nature extensions of the covered work,
-and which are not combined with it such as to form a larger program,
-in or on a volume of a storage or distribution medium, is called an
-"aggregate" if the compilation and its resulting copyright are not
-used to limit the access or legal rights of the compilation's users
-beyond what the individual works permit.  Inclusion of a covered work
-in an aggregate does not cause this License to apply to the other
-parts of the aggregate.
-
-  6. Conveying Non-Source Forms.
-
-  You may convey a covered work in object code form under the terms
-of sections 4 and 5, provided that you also convey the
-machine-readable Corresponding Source under the terms of this License,
-in one of these ways:
-
-    a) Convey the object code in, or embodied in, a physical product
-    (including a physical distribution medium), accompanied by the
-    Corresponding Source fixed on a durable physical medium
-    customarily used for software interchange.
-
-    b) Convey the object code in, or embodied in, a physical product
-    (including a physical distribution medium), accompanied by a
-    written offer, valid for at least three years and valid for as
-    long as you offer spare parts or customer support for that product
-    model, to give anyone who possesses the object code either (1) a
-    copy of the Corresponding Source for all the software in the
-    product that is covered by this License, on a durable physical
-    medium customarily used for software interchange, for a price no
-    more than your reasonable cost of physically performing this
-    conveying of source, or (2) access to copy the
-    Corresponding Source from a network server at no charge.
-
-    c) Convey individual copies of the object code with a copy of the
-    written offer to provide the Corresponding Source.  This
-    alternative is allowed only occasionally and noncommercially, and
-    only if you received the object code with such an offer, in accord
-    with subsection 6b.
-
-    d) Convey the object code by offering access from a designated
-    place (gratis or for a charge), and offer equivalent access to the
-    Corresponding Source in the same way through the same place at no
-    further charge.  You need not require recipients to copy the
-    Corresponding Source along with the object code.  If the place to
-    copy the object code is a network server, the Corresponding Source
-    may be on a different server (operated by you or a third party)
-    that supports equivalent copying facilities, provided you maintain
-    clear directions next to the object code saying where to find the
-    Corresponding Source.  Regardless of what server hosts the
-    Corresponding Source, you remain obligated to ensure that it is
-    available for as long as needed to satisfy these requirements.
-
-    e) Convey the object code using peer-to-peer transmission, provided
-    you inform other peers where the object code and Corresponding
-    Source of the work are being offered to the general public at no
-    charge under subsection 6d.
-
-  A separable portion of the object code, whose source code is excluded
-from the Corresponding Source as a System Library, need not be
-included in conveying the object code work.
-
-  A "User Product" is either (1) a "consumer product", which means any
-tangible personal property which is normally used for personal, family,
-or household purposes, or (2) anything designed or sold for incorporation
-into a dwelling.  In determining whether a product is a consumer product,
-doubtful cases shall be resolved in favor of coverage.  For a particular
-product received by a particular user, "normally used" refers to a
-typical or common use of that class of product, regardless of the status
-of the particular user or of the way in which the particular user
-actually uses, or expects or is expected to use, the product.  A product
-is a consumer product regardless of whether the product has substantial
-commercial, industrial or non-consumer uses, unless such uses represent
-the only significant mode of use of the product.
-
-  "Installation Information" for a User Product means any methods,
-procedures, authorization keys, or other information required to install
-and execute modified versions of a covered work in that User Product from
-a modified version of its Corresponding Source.  The information must
-suffice to ensure that the continued functioning of the modified object
-code is in no case prevented or interfered with solely because
-modification has been made.
-
-  If you convey an object code work under this section in, or with, or
-specifically for use in, a User Product, and the conveying occurs as
-part of a transaction in which the right of possession and use of the
-User Product is transferred to the recipient in perpetuity or for a
-fixed term (regardless of how the transaction is characterized), the
-Corresponding Source conveyed under this section must be accompanied
-by the Installation Information.  But this requirement does not apply
-if neither you nor any third party retains the ability to install
-modified object code on the User Product (for example, the work has
-been installed in ROM).
-
-  The requirement to provide Installation Information does not include a
-requirement to continue to provide support service, warranty, or updates
-for a work that has been modified or installed by the recipient, or for
-the User Product in which it has been modified or installed.  Access to a
-network may be denied when the modification itself materially and
-adversely affects the operation of the network or violates the rules and
-protocols for communication across the network.
-
-  Corresponding Source conveyed, and Installation Information provided,
-in accord with this section must be in a format that is publicly
-documented (and with an implementation available to the public in
-source code form), and must require no special password or key for
-unpacking, reading or copying.
-
-  7. Additional Terms.
-
-  "Additional permissions" are terms that supplement the terms of this
-License by making exceptions from one or more of its conditions.
-Additional permissions that are applicable to the entire Program shall
-be treated as though they were included in this License, to the extent
-that they are valid under applicable law.  If additional permissions
-apply only to part of the Program, that part may be used separately
-under those permissions, but the entire Program remains governed by
-this License without regard to the additional permissions.
-
-  When you convey a copy of a covered work, you may at your option
-remove any additional permissions from that copy, or from any part of
-it.  (Additional permissions may be written to require their own
-removal in certain cases when you modify the work.)  You may place
-additional permissions on material, added by you to a covered work,
-for which you have or can give appropriate copyright permission.
-
-  Notwithstanding any other provision of this License, for material you
-add to a covered work, you may (if authorized by the copyright holders of
-that material) supplement the terms of this License with terms:
-
-    a) Disclaiming warranty or limiting liability differently from the
-    terms of sections 15 and 16 of this License; or
-
-    b) Requiring preservation of specified reasonable legal notices or
-    author attributions in that material or in the Appropriate Legal
-    Notices displayed by works containing it; or
-
-    c) Prohibiting misrepresentation of the origin of that material, or
-    requiring that modified versions of such material be marked in
-    reasonable ways as different from the original version; or
-
-    d) Limiting the use for publicity purposes of names of licensors or
-    authors of the material; or
-
-    e) Declining to grant rights under trademark law for use of some
-    trade names, trademarks, or service marks; or
-
-    f) Requiring indemnification of licensors and authors of that
-    material by anyone who conveys the material (or modified versions of
-    it) with contractual assumptions of liability to the recipient, for
-    any liability that these contractual assumptions directly impose on
-    those licensors and authors.
-
-  All other non-permissive additional terms are considered "further
-restrictions" within the meaning of section 10.  If the Program as you
-received it, or any part of it, contains a notice stating that it is
-governed by this License along with a term that is a further
-restriction, you may remove that term.  If a license document contains
-a further restriction but permits relicensing or conveying under this
-License, you may add to a covered work material governed by the terms
-of that license document, provided that the further restriction does
-not survive such relicensing or conveying.
-
-  If you add terms to a covered work in accord with this section, you
-must place, in the relevant source files, a statement of the
-additional terms that apply to those files, or a notice indicating
-where to find the applicable terms.
-
-  Additional terms, permissive or non-permissive, may be stated in the
-form of a separately written license, or stated as exceptions;
-the above requirements apply either way.
-
-  8. Termination.
-
-  You may not propagate or modify a covered work except as expressly
-provided under this License.  Any attempt otherwise to propagate or
-modify it is void, and will automatically terminate your rights under
-this License (including any patent licenses granted under the third
-paragraph of section 11).
-
-  However, if you cease all violation of this License, then your
-license from a particular copyright holder is reinstated (a)
-provisionally, unless and until the copyright holder explicitly and
-finally terminates your license, and (b) permanently, if the copyright
-holder fails to notify you of the violation by some reasonable means
-prior to 60 days after the cessation.
-
-  Moreover, your license from a particular copyright holder is
-reinstated permanently if the copyright holder notifies you of the
-violation by some reasonable means, this is the first time you have
-received notice of violation of this License (for any work) from that
-copyright holder, and you cure the violation prior to 30 days after
-your receipt of the notice.
-
-  Termination of your rights under this section does not terminate the
-licenses of parties who have received copies or rights from you under
-this License.  If your rights have been terminated and not permanently
-reinstated, you do not qualify to receive new licenses for the same
-material under section 10.
-
-  9. Acceptance Not Required for Having Copies.
-
-  You are not required to accept this License in order to receive or
-run a copy of the Program.  Ancillary propagation of a covered work
-occurring solely as a consequence of using peer-to-peer transmission
-to receive a copy likewise does not require acceptance.  However,
-nothing other than this License grants you permission to propagate or
-modify any covered work.  These actions infringe copyright if you do
-not accept this License.  Therefore, by modifying or propagating a
-covered work, you indicate your acceptance of this License to do so.
-
-  10. Automatic Licensing of Downstream Recipients.
-
-  Each time you convey a covered work, the recipient automatically
-receives a license from the original licensors, to run, modify and
-propagate that work, subject to this License.  You are not responsible
-for enforcing compliance by third parties with this License.
-
-  An "entity transaction" is a transaction transferring control of an
-organization, or substantially all assets of one, or subdividing an
-organization, or merging organizations.  If propagation of a covered
-work results from an entity transaction, each party to that
-transaction who receives a copy of the work also receives whatever
-licenses to the work the party's predecessor in interest had or could
-give under the previous paragraph, plus a right to possession of the
-Corresponding Source of the work from the predecessor in interest, if
-the predecessor has it or can get it with reasonable efforts.
-
-  You may not impose any further restrictions on the exercise of the
-rights granted or affirmed under this License.  For example, you may
-not impose a license fee, royalty, or other charge for exercise of
-rights granted under this License, and you may not initiate litigation
-(including a cross-claim or counterclaim in a lawsuit) alleging that
-any patent claim is infringed by making, using, selling, offering for
-sale, or importing the Program or any portion of it.
-
-  11. Patents.
-
-  A "contributor" is a copyright holder who authorizes use under this
-License of the Program or a work on which the Program is based.  The
-work thus licensed is called the contributor's "contributor version".
-
-  A contributor's "essential patent claims" are all patent claims
-owned or controlled by the contributor, whether already acquired or
-hereafter acquired, that would be infringed by some manner, permitted
-by this License, of making, using, or selling its contributor version,
-but do not include claims that would be infringed only as a
-consequence of further modification of the contributor version.  For
-purposes of this definition, "control" includes the right to grant
-patent sublicenses in a manner consistent with the requirements of
-this License.
-
-  Each contributor grants you a non-exclusive, worldwide, royalty-free
-patent license under the contributor's essential patent claims, to
-make, use, sell, offer for sale, import and otherwise run, modify and
-propagate the contents of its contributor version.
-
-  In the following three paragraphs, a "patent license" is any express
-agreement or commitment, however denominated, not to enforce a patent
-(such as an express permission to practice a patent or covenant not to
-sue for patent infringement).  To "grant" such a patent license to a
-party means to make such an agreement or commitment not to enforce a
-patent against the party.
-
-  If you convey a covered work, knowingly relying on a patent license,
-and the Corresponding Source of the work is not available for anyone
-to copy, free of charge and under the terms of this License, through a
-publicly available network server or other readily accessible means,
-then you must either (1) cause the Corresponding Source to be so
-available, or (2) arrange to deprive yourself of the benefit of the
-patent license for this particular work, or (3) arrange, in a manner
-consistent with the requirements of this License, to extend the patent
-license to downstream recipients.  "Knowingly relying" means you have
-actual knowledge that, but for the patent license, your conveying the
-covered work in a country, or your recipient's use of the covered work
-in a country, would infringe one or more identifiable patents in that
-country that you have reason to believe are valid.
-
-  If, pursuant to or in connection with a single transaction or
-arrangement, you convey, or propagate by procuring conveyance of, a
-covered work, and grant a patent license to some of the parties
-receiving the covered work authorizing them to use, propagate, modify
-or convey a specific copy of the covered work, then the patent license
-you grant is automatically extended to all recipients of the covered
-work and works based on it.
-
-  A patent license is "discriminatory" if it does not include within
-the scope of its coverage, prohibits the exercise of, or is
-conditioned on the non-exercise of one or more of the rights that are
-specifically granted under this License.  You may not convey a covered
-work if you are a party to an arrangement with a third party that is
-in the business of distributing software, under which you make payment
-to the third party based on the extent of your activity of conveying
-the work, and under which the third party grants, to any of the
-parties who would receive the covered work from you, a discriminatory
-patent license (a) in connection with copies of the covered work
-conveyed by you (or copies made from those copies), or (b) primarily
-for and in connection with specific products or compilations that
-contain the covered work, unless you entered into that arrangement,
-or that patent license was granted, prior to 28 March 2007.
-
-  Nothing in this License shall be construed as excluding or limiting
-any implied license or other defenses to infringement that may
-otherwise be available to you under applicable patent law.
-
-  12. No Surrender of Others' Freedom.
-
-  If conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License.  If you cannot convey a
-covered work so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you may
-not convey it at all.  For example, if you agree to terms that obligate you
-to collect a royalty for further conveying from those to whom you convey
-the Program, the only way you could satisfy both those terms and this
-License would be to refrain entirely from conveying the Program.
-
-  13. Use with the GNU Affero General Public License.
-
-  Notwithstanding any other provision of this License, you have
-permission to link or combine any covered work with a work licensed
-under version 3 of the GNU Affero General Public License into a single
-combined work, and to convey the resulting work.  The terms of this
-License will continue to apply to the part which is the covered work,
-but the special requirements of the GNU Affero General Public License,
-section 13, concerning interaction through a network will apply to the
-combination as such.
-
-  14. Revised Versions of this License.
-
-  The Free Software Foundation may publish revised and/or new versions of
-the GNU General Public License from time to time.  Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
-  Each version is given a distinguishing version number.  If the
-Program specifies that a certain numbered version of the GNU General
-Public License "or any later version" applies to it, you have the
-option of following the terms and conditions either of that numbered
-version or of any later version published by the Free Software
-Foundation.  If the Program does not specify a version number of the
-GNU General Public License, you may choose any version ever published
-by the Free Software Foundation.
-
-  If the Program specifies that a proxy can decide which future
-versions of the GNU General Public License can be used, that proxy's
-public statement of acceptance of a version permanently authorizes you
-to choose that version for the Program.
-
-  Later license versions may give you additional or different
-permissions.  However, no additional obligations are imposed on any
-author or copyright holder as a result of your choosing to follow a
-later version.
-
-  15. Disclaimer of Warranty.
-
-  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
-APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
-HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
-OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
-THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
-IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
-ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
-
-  16. Limitation of Liability.
-
-  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
-THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
-GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
-USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
-DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
-PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
-EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
-SUCH DAMAGES.
-
-  17. Interpretation of Sections 15 and 16.
-
-  If the disclaimer of warranty and limitation of liability provided
-above cannot be given local legal effect according to their terms,
-reviewing courts shall apply local law that most closely approximates
-an absolute waiver of all civil liability in connection with the
-Program, unless a warranty or assumption of liability accompanies a
-copy of the Program in return for a fee.
-
-              END OF TERMS AND CONDITIONS
-
-     How to Apply These Terms to Your New Programs
-
-  If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
-  To do so, attach the following notices to the program.  It is safest
-to attach them to the start of each source file to most effectively
-state the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
-    <one line to give the program's name and a brief idea of what it does.>
-    Copyright (C) <year>  <name of author>
-
-    This program is free software: you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation, either version 3 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program.  If not, see <http://www.gnu.org/licenses/>.
-
-Also add information on how to contact you by electronic and paper mail.
-
-  If the program does terminal interaction, make it output a short
-notice like this when it starts in an interactive mode:
-
-    <program>  Copyright (C) <year>  <name of author>
-    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
-    This is free software, and you are welcome to redistribute it
-    under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License.  Of course, your program's commands
-might be different; for a GUI interface, you would use an "about box".
-
-  You should also get your employer (if you work as a programmer) or school,
-if any, to sign a "copyright disclaimer" for the program, if necessary.
-For more information on this, and how to apply and follow the GNU GPL, see
-<http://www.gnu.org/licenses/>.
-
-  The GNU General Public License does not permit incorporating your program
-into proprietary programs.  If your program is a subroutine library, you
-may consider it more useful to permit linking proprietary applications with
-the library.  If this is what you want to do, use the GNU Lesser General
-Public License instead of this License.  But first, please read
-<http://www.gnu.org/philosophy/why-not-lgpl.html>.

vendored/ansi-terminal-game-1.8.0.0/NEWS

@@ -1,275 +0,0 @@
-1.8.0.0
--------
-
-- Fixed testing facilities `recordGame`, `testGame`, `narrateGame` and
-  similar functions. `testGame` in particular is able to precisely
-  emulate recorded environment (so if your game has a bug only at a
-  specific size, `testGame` will now catch it).
-  Check `cabal run -f alone-playback examples ` to see a replay in action
-  and `test/Terminal/Game/Layer/ImperativeSpec.hs` for pure test ideas.
-- Added information on how to have an hot-reload mode, albeit only for
-  non-interactive game replays. Check `example/MainHotReload.hs` if
-  interested.
-- Added a new exception, `DisplayTooSmall`, which expands gracefully to
-  a “please resize your terminal” message to the player if uncaught.
-  Nothing changes if you do not already use `asserTermDims`.
-- `assertTermDims` is now curries (`Width -> Height -> IO ()` instead
-  of `Dimensions -> IO ()`) to better fit the rest of the API.
-- Modified behaviour of functions `vcat`, `hcat`, `stringPlane`,
-  `stringPlaneTrans`. They will not error on empty list, rather return
-  a transparent, 1×1 plane.
-- Changed licence and changes files to COPYING and NEWS.
-
-1.7.0.0
--------
-
-- After some feedback from library users, I decided to eliminate
-  `simpleGame` from the API.
-  To reiterate hte migration guide, if your type was:
-
-    Game 80 24 13 initState logicFun drawFun quitFun
-    -- or
-    -- simpleGame (80, 24) 13 initState logicFun drawFun quitFun
-
-  You just need to modify it like this:
-
-    Game 13 initState
-                (const logicFun)
-                (\e s -> centerFull e $ drawFun s)
-                quitFun
-        -- notice how we lost `80 24`. You can still have a screen size
-        -- check with `assertTermDims`, as described below.
-- Added `blankPlaneFull` and `centerFull` convenience functions (to work
-  with GEnv terminal dimensions).
-- Added assertTermDims, a quick way to check your user terminal is big
-  enough at the start of the game.
-- minimal blitting optimisation (you should be able to see a 1–2
-  FPS improvement).
-- improved documentation on various functions.
-
-1.6.0.2
--------
-
-- lun 15 nov 2021, 02:21:08
-- more doc tweaking
-
-1.6.0.1
--------
-
-- released lun 15 nov 2021, 00:35:41
-- minor documentation / spelling fixes
-
-1.6.0.0
--------
-
-Summary and tl;dr migration guide:
-- This version introduces a breaking changes in the main way to make
-  a `Game`. I will detail the changes below, but first a three-lines
-  migration guide:
-    the only thing you should have to do is to replace your `Game`
-    data constructor with `simpleGame` smart constructor, and substitute
-    the first to `c` `r` arguments (col/row) with a `(c, r)` tuple.
-  And of course, if you are interested in displaying FPS and adapt to
-  screen size modifications at game-time (“liquid” layout), read along!
-
-Changes:
-- This version introduces GEnv, a structure that exposes current frame
-  rate (in FPS) and current terminal size (in Width, Height).
-- `GEnv` is added as a parameter to logic and draw functions, which
-  now have these signatures:
-    gLogicFunction :: GEnv -> s -> Event -> slightly
-    gDrawFunction :: GEnv -> s -> plane
-- If you do not want to dabble with GEnv, you can still use `simpleGame`
-  smart constructor, which mimicks the old `Game`. `simpleGame` has some
-  nice defaults:
-    - if the terminal is too small it will ask the player to resize it
-      (even in the middle of the game), blocking any input;
-    - if the terminal is bigger, it will paste `Plane` in the middle
-      of the screen.
-- For this reason, `DisplayTooSmall` exception exists no more.
-- the new `Game` does not have those defaults, but allows you to get
-  creative with screen resizes, e.g. accomodating as much gameworld
-  as possible etc. Check `cabal run -f examples balls` and resize the
-  screen to see it in action.
-- Minor change: I have introduced a `Dimensions` alias for
-  `(Width, Height)`.
-
-Future work:
-- these changes lay the path for an even more general `Game` type,
-  adding effects like reading form a game configuration, writing to it
-  etc.
-  I would like to have these wrapped in a pure interface (maybe à la
-  Response/Request? Maybe callbacks?) and for sure want them to be
-  composable with current test scaffolding (testGame,
-  narrateGame, etc.). It will not be easy to design; if are reading
-  this and have any suggestion, please write to me.
-
-Released dom 14 nov 2021, 20:25:19
-
-1.5.0.0
--------
-
-- `timers-tick` has released a new version: all timers function (creaTimer,
-  creaBoolTimer, creaTimerLoop, creaBoolTimerLoop, creaAnimation,
-  creaLoopAnimation, ticks) are slightly more robust now (will `error`
-  on nonsenical arguments, e.g. frame duration <1).
-  This should not impact any of your current projects, it just makes
-  catching bugs easier.
-- Removed `getFrames` from Animation interface.
-- Updated `Random` interface to fit the new `random`. This is a breaking
-  change but it should be easy to fix by updating your `Random` constraints
-  to `UniformRange`.
-  Be mindful that `recordGame` could play slightly differently, as the
-  update function for the StdGen in `random` has changed.
-- Removed `getRandomList` from Random interface.
-- Added `pickRandom` to Random interface.
-- Removed unuseful `creaStaticAnimation` from Animation interface.
-- Released mar 9 nov 2021, 15:56:14.
-
-1.4.0.0
--------
-
-- Fixed an annoying bug that made a game run slower than expected on
-  low TPS. Now if you select 5 ticks per second, you can rest assured
-  that after 50 ticks, 5 seconds have elapsed.
-- Renamed `FPS` to `TPS` (ticks per second); highlight logic speed is
-  constant timewise on all machines, while FPS might be different on
-  differently efficient terminals.
-  This will allow in future releases to provide a function to easily
-  calculate actual FPS of the game.
-- Added alternative origin combinators `%^>`, `%.<`, `%.>`; they are
-  useful when you want to — e.g. — «paste a plane one row from
-  bottom-right corner».
-
-1.3.0.0
--------
-
-- `displaySize` and `playGame`/`playGameS` now throw an exception
-  (of type `ATGException`) instead of `error`ing. These exeptions are
-  `CannotGetDisplaySize` and `DisplayTooSmall`; they are synchronous,
-  for easier catching. (requested by sm)
-- Released sab 16 ott 2021, 21:09:22
-
-1.2.1.0
--------
-
-- Fixed textBox, textBoxHyphen bug (boxes were not transparent, contrary
-  to what stated in docs) (reported by sm).
-- Released lun 11 ott 2021, 22:29:40
-
-1.2.0.0
--------
-
-- Added textBoxHyphen and textBoxHyphenLiquid and a handful of `Hypenator`s.
-  This will allow you to have autohyphenation in textboxes. Compare:
-    (normal textbox)                       (hyphenated textbox)
-    Rimasi un po’ a meditare nel buio      Rimasi un po’ a meditare nel buio
-    velato appena dal barlume azzurrino    velato appena dal barlume azzurrino
-    del fornello a gas, su cui             del fornello a gas, su cui sobbol-
-    sobbollliva quieta la pentola.         liva quieta la pentola.
-- Switched `Width`, `Height`, `Row`, `Col` from `Integer` to `Int`.
-  This is unfortunate, but will make playing with `base` simpler. I will
-  switch it back once `Prelude` handles both integers appropriately
-  or exports the relevant function. (request by sm)
-- Changed signature for `box`, `textBox` and `textBoxLiquid`. Now
-  width/height parameters come *before* the character/string. E.g.:
-    textBoxLiquid :: String -> Width -> Plane  -- this was before
-    textBoxLiquid :: Width -> String -> Plane  -- this is now
-  This felt more ergonomic while writing games.
-- `paperPlane` is now `planePaper` (to respect SVO order)
-
-1.1.1.0
--------
-
-- Added (***) (centre blit) (request by sm)
-- Released gio 30 set 2021, 12:29:22
-
-1.1.0.0
--------
-
-- Added Plane justapoxition functions (===, |||, vcat, hcat).
-- Added `word` and and `textBoxLiquid` drawing functions.
-- Added `subPlane`, `displaySize` Plane functions.
-- Removed unused `trimPlane`.
-- Sanitized non-ASCII chars on Win32 console.
-- Wed 03 Feb 2021 18:41:20 CET
-
-1.0.0.0
--------
-
-- Milestone release.
-- Beefed up documentation.
-- Released Sun 08 Dec 2019 04:19:33 CET
-
-0.7.2.0
--------
-
-- Fixed 0.7.1.0 unbumped dependency.
-- Released Fri 22 Nov 2019 16:51:25 CET
-
-0.7.1.0
--------
-
-- Fixed 0.7.0.0 (deprecated) interface.
-- Released Fri 22 Nov 2019 14:51:40 CET
-
-0.7.0.0
--------
-
-- Simplified Animation interface (breaking changes).
-- Added `creaLoopAnimation` and `creaStaticAnimation`.
-- Released Fri 22 Nov 2019 14:40:44 CET
-
-0.6.1.0
--------
-
-- Reworked Timers/Animations interface and documentation.
-- Added `lapse` (for Timers/Animations).
-- Released Fri 22 Nov 2019 01:03:37 CET
-
-0.6.0.1
--------
-
-- Add public repo (requested by sm).
-- Released Tue 19 Nov 2019 22:38:34 CET
-
-0.6.0.0
--------
-
-- Add random generation functions.
-- Released Sun 10 Nov 2019 13:44:32 CET
-
-0.5.0.0
--------
-
-- Add `setupGame` to setup games before playtesting (skip menus, etc.).
-- Fixed screen corruption on Windows.
-- Released Fri 08 Nov 2019 13:52:39 CET
-
-0.4.0.0
--------
-
-- Exposed new functions in API.
-- Greatly improved haddock documentation.
-- Released Tue 25 Jun 2019 16:08:53 CEST
-
-0.2.1.0
--------
-
-- Improved haddock documentation a bit.
-- Cleanup runs regardless of exception.
-- Released on Sun 18 Mar 2018 03:04:07 CET.
-
-0.2.0.0
--------
-
-- Added dependencies constraints.
-- Removed internal module.
-- Fixed changelog.
-- Released on Fri 16 Mar 2018 00:42:41 CET.
-
-0.1.0.0
--------
-
-- Initial release.
-- Released on Fri 16 Mar 2018 00:33:18 CET.

vendored/ansi-terminal-game-1.8.0.0/README

@@ -1,46 +0,0 @@
-==================
-ansi-terminal-game
-==================
-
-`ansi-terminal-game` is a library for creating games in a terminal setting.
-
-Goals
------
-
-- be cross platform (linux/win/mac). If you plan to have your executable
-  unix only, I invite you to check brick [1] or other, more expressive
-  libraries.
-- be simple: no curses/ncurses/pdcurses/etc. dependencies, all
-  functionality built on a standard input / ANSI terminal base.
-
-[1] http://hackage.haskell.org/package/brick
-
-Learn
------
-
-- run the basic example with `cabal new-run -f examples alone`;
-- check the source in `examples/Alone.hs`;
-- open the 'Terminal.Game' haddock documentation (start reading from
-  `Data.Game`).
-
-A full game can be found at:
-
-    http://www.ariis.it/static/articles/venzone/page.html
-
-Other games made with a-t-g
----------------------------
-
-- caverunner:
-    https://github.com/simonmichael/games/blob/main/caverunner/caverunner.hs
-- pigafetta: http://www.ariis.it/link/repos/pigafetta/
-- avoidance: https://sabadev.xyz/avoidance_game
-
-If you want yours to be added to this list, write to me.
-
-Contact
--------
-
-For any feedback or report, contact me at:
-
-    http://ariis.it/static/articles/mail/page.html
-

vendored/ansi-terminal-game-1.8.0.0/Setup.hs

@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain

vendored/ansi-terminal-game-1.8.0.0/ansi-terminal-game.cabal

@@ -1,188 +0,0 @@
-name:                ansi-terminal-game
-version:             1.8.0.0
-synopsis:            sdl-like functions for terminal applications, based on
-                     ansi-terminal
-description:         Library which aims to replicate standard 2d game
-                     functions (blit, ticks, timers, etc.) in a terminal
-                     setting; features double buffering to optimise
-                     performance.
-                     Aims to be cross compatible (based on "ansi-terminal",
-                     no unix-only dependencies), practical.
-                     See @examples@ folder for some minimal programs.  A
-                     full game: <http://www.ariis.it/static/articles/venzone/page.html venzone>.
-homepage:            http://www.ariis.it/static/articles/ansi-terminal-game/page.html
-license:             GPL-3
-license-file:        COPYING
-author:              Francesco Ariis
-maintainer:          fa-ml@ariis.it
-copyright:           © 2017-2021 Francesco Ariis
-category:            Game
-build-type:          Simple
-extra-source-files:  README,
-                     NEWS,
-                     test/records/alone-record-test.gr
-                     test/records/balls-dims.gr
-                     test/records/balls-slow.gr
-cabal-version:       >=1.10
-
-flag examples
-  description:       builds examples
-  default:           False
-
-source-repository head
-    type:     darcs
-    location: http://www.ariis.it/link/repos/ansi-terminal-game/
-
-library
-  exposed-modules:     Terminal.Game
-  other-modules:       Terminal.Game.Animation,
-                       Terminal.Game.Character,
-                       Terminal.Game.Draw,
-                       Terminal.Game.Layer.Imperative,
-                       Terminal.Game.Layer.Object,
-                       Terminal.Game.Layer.Object.GameIO,
-                       Terminal.Game.Layer.Object.Interface,
-                       Terminal.Game.Layer.Object.IO,
-                       Terminal.Game.Layer.Object.Narrate,
-                       Terminal.Game.Layer.Object.Primitive,
-                       Terminal.Game.Layer.Object.Record,
-                       Terminal.Game.Layer.Object.Test,
-                       Terminal.Game.Utils,
-                       Terminal.Game.Plane,
-                       Terminal.Game.Random,
-                       Terminal.Game.Timer
-  build-depends:       base == 4.*,
-                       ansi-terminal == 0.11.*,
-                       array == 0.5.*,
-                       bytestring >= 0.10 && < 0.12,
-                       cereal == 0.5.*,
-                       clock >= 0.7 && < 0.9,
-                       containers == 0.6.*,
-                       exceptions == 0.10.*,
-                       linebreak == 1.1.*,
-                       mintty == 0.1.*,
-                       mtl == 2.2.*,
-                       QuickCheck >= 2.13 && < 2.15,
-                       random >= 1.2 && < 1.3,
-                       split == 0.2.*,
-                       terminal-size == 0.3.*,
-                       unidecode >= 0.1.0 && < 0.2,
-                       timers-tick > 0.5 && < 0.6
-  hs-source-dirs:      src
-  default-language:    Haskell2010
-  ghc-options:         -Wall
-
-  if os(windows)
-    hs-source-dirs: platform-dep/windows
-  if !os(windows)
-    hs-source-dirs: platform-dep/non-win
-
-test-suite test
-  default-language:    Haskell2010
-  hs-Source-Dirs:      test, src, example
-  main-is:             Test.hs
-  other-modules:       Alone,
-                       Balls,
-                       Terminal.Game,
-                       Terminal.Game.Animation,
-                       Terminal.Game.Character,
-                       Terminal.Game.Draw,
-                       Terminal.Game.DrawSpec,
-                       Terminal.Game.Layer.Imperative,
-                       Terminal.Game.Layer.ImperativeSpec,
-                       Terminal.Game.Layer.Object,
-                       Terminal.Game.Layer.Object.GameIO,
-                       Terminal.Game.Layer.Object.Interface,
-                       Terminal.Game.Layer.Object.IO,
-                       Terminal.Game.Layer.Object.Narrate,
-                       Terminal.Game.Layer.Object.Primitive,
-                       Terminal.Game.Layer.Object.Record,
-                       Terminal.Game.Layer.Object.Test,
-                       Terminal.Game.Utils,
-                       Terminal.Game.Plane,
-                       Terminal.Game.PlaneSpec
-                       Terminal.Game.Random,
-                       Terminal.Game.RandomSpec
-  build-depends:       base == 4.*,
-                       ansi-terminal == 0.11.*,
-                       array == 0.5.*,
-                       bytestring >= 0.10 && < 0.12,
-                       cereal == 0.5.*,
-                       clock >= 0.7 && < 0.9,
-                       containers == 0.6.*,
-                       exceptions == 0.10.*,
-                       linebreak == 1.1.*,
-                       mintty == 0.1.*,
-                       mtl == 2.2.*,
-                       QuickCheck >= 2.13 && < 2.15,
-                       random >= 1.2 && < 1.3,
-                       split == 0.2.*,
-                       terminal-size == 0.3.*,
-                       unidecode >= 0.1.0 && < 0.2,
-                       timers-tick > 0.5 && < 0.6
-                       -- the above plus hspec
-                       , hspec
-  type:                exitcode-stdio-1.0
-  ghc-options:         -Wall
-
-  if os(windows)
-    hs-source-dirs: platform-dep/windows
-  if !os(windows)
-    hs-source-dirs: platform-dep/non-win
-
-executable alone
-    if flag(examples)
-      build-depends:  base == 4.*,
-                      ansi-terminal-game
-    else
-      buildable:      False
-
-    hs-source-dirs:   example
-    main-is:          MainAlone.hs
-    other-modules:    Alone
-    default-language: Haskell2010
-    ghc-options:      -threaded
-                      -Wall
-
-executable alone-playback
-    if flag(examples)
-      build-depends:  base == 4.*,
-                      ansi-terminal-game,
-                      temporary == 1.3.*
-    else
-      buildable:      False
-
-    hs-source-dirs:   example
-    main-is:          MainPlayback.hs
-    other-modules:    Alone
-    default-language: Haskell2010
-    ghc-options:      -threaded
-                      -Wall
-
-executable balls
-    if flag(examples)
-      build-depends:  base == 4.*,
-                      ansi-terminal-game
-    else
-      buildable:      False
-
-    hs-source-dirs:   example
-    main-is:          MainBalls.hs
-    other-modules:    Balls
-    default-language: Haskell2010
-    ghc-options:      -threaded
-                      -Wall
-
-executable hot-reload
-    if flag(examples)
-      build-depends:  base == 4.*,
-                      ansi-terminal-game
-    else
-      buildable:      False
-
-    hs-source-dirs:   example
-    main-is:          MainHotReload.hs
-    other-modules:    Alone
-    default-language: Haskell2010
-    ghc-options:      -threaded
-                      -Wall

vendored/ansi-terminal-game-1.8.0.0/example/Alone.hs

@@ -1,90 +0,0 @@
-module Alone where
-
--- Alone in a room, game definition (logic & draw)
--- run with: cabal new-run -f examples alone
-
-import Terminal.Game
-
-import qualified Data.Tuple as T
-
--- game specification
-aloneInARoom :: Game MyState
-aloneInARoom = Game 13                       -- ticks per second
-                    (MyState (10, 10)
-                             Stop False)     -- init state
-                    (\_ s e -> logicFun s e) -- logic function
-                    (\r s -> centerFull r $
-                               drawFun s)    -- draw function
-                    gsQuit                   -- quit function
-
-sizeCheck :: IO ()
-sizeCheck = let (w, h) = T.swap . snd $ boundaries
-            in assertTermDims w h
-
--------------------------------------------------------------------------------
--- Types
-
-data MyState = MyState { gsCoord :: Coords,
-                         gsMove  :: Move,
-                         gsQuit  :: Bool }
-             deriving (Show, Eq)
-
-data Move = N | S | E | W | Stop
-          deriving (Show, Eq)
-
-boundaries :: (Coords, Coords)
-boundaries = ((1, 1), (24, 80))
-
--------------------------------------------------------------------------------
--- Logic
-
-logicFun :: MyState -> Event -> MyState
-logicFun gs (KeyPress 'q') = gs { gsQuit = True }
-logicFun gs Tick           = gs { gsCoord = pos (gsMove gs) (gsCoord gs) }
-logicFun gs (KeyPress c)   = gs { gsMove = move (gsMove gs) c }
-
--- SCI movement
-move :: Move -> Char -> Move
-move N 'w' = Stop
-move S 's' = Stop
-move W 'a' = Stop
-move E 'd' = Stop
-move _ 'w' = N
-move _ 's' = S
-move _ 'a' = W
-move _ 'd' = E
-move m _   = m
-
-pos :: Move -> (Width, Height) -> (Width, Height)
-pos m oldcs | oob newcs = oldcs
-            | otherwise = newcs
-    where
-          newcs = new m oldcs
-
-          new Stop cs = cs
-          new N    (r, c) = (r-1, c  )
-          new S    (r, c) = (r+1, c  )
-          new E    (r, c) = (r  , c+1)
-          new W    (r, c) = (r  , c-1)
-
-          ((lr, lc), (hr, hc)) = boundaries
-          oob (r, c) = r <= lr || c <= lc ||
-                       r >= hr || c >= hc
-
--------------------------------------------------------------------------------
--- Draw
-
-drawFun :: MyState -> Plane
-drawFun (MyState (r, c) _ _) =
-                           blankPlane mw     mh            &
-                (1, 1)   % box mw mh '-'                   &
-                (2, 2)   % box (mw-2) (mh-2) ' '           &
-                (15, 20) % textBox 10 4
-                                   "Tap WASD to move, tap again to stop." &
-                (20, 60) % textBox 8 10
-                                   "Press Q to quit." # color Blue Vivid &
-                (r, c) % cell '@' # invert
-    where
-          mh :: Height
-          mw :: Width
-          (mh, mw) = snd boundaries

vendored/ansi-terminal-game-1.8.0.0/example/Balls.hs

@@ -1,189 +0,0 @@
-module Balls where
-
--- library module for `balls`
-
-import Terminal.Game
-
-import qualified Data.Bool as B
-import qualified Data.Ix as I
-import qualified Data.Maybe as M
-import qualified Data.Tuple as T
-
-{-
-   There are three things I will showcase in this example:
-
-   1. ** How you can display current FPS. **
-      This is done using `Game` to create your game rather than
-      `simpleGame`. `Game` is a bit more complex but you gain
-      additional infos to manipulate/blit, like FPS.
-
-   2. ** How your game can gracefully handle screen resize. **
-      Notice how if you resize the terminal, balls will still
-      fill the entire screen. This is again possible using `Game`
-      and the information passed via GameEnv (in this case, terminal
-      dimensions).
-
-   3. ** That — while FPS can change  — game speed does not. **
-      Check the timer: even when screen is crowded and frames are
-      dropped, it is not slowed down.
-
-
-   This game runs at 60 FPS, you will almost surely never need such
-   a high TPS! 15–20 is more than enough in most cases.
--}
-
--------------------------------------------------------------------------------
--- Ball
-
-data Ball = Ball { pChar :: Plane,
-                   pSpeed :: Timed Bool,
-                   pDir :: Coords,
-                   pPos :: Coords }
-
--- change direction is necessary, then and move
-modPar :: Dimensions -> Ball -> Maybe Ball
-modPar ds b@(Ball _ _ d _) =
-            -- tick the ball and check it is time to move
-            let b' = tickBall b in
-            if not (fetchFrame . pSpeed $ b')
-              then Just b' -- no time to move for you
-            else
-
-            -- check all popssible directions
-            let pd = [d, togR d, togC d, togB d]
-                bs  = map (\ld -> b' { pDir = ld })  pd
-                bs' = filter (isIn ds) $ map modPos bs in
-
-            -- returns a moved ball nor nothing to mark it “to eliminate”
-            case bs' of
-              [] -> Nothing
-              (cp:_) -> Just cp
-    where
-          togR (wr, wc) = (-wr,  wc)
-          togC (wr, wc) = ( wr, -wc)
-          togB (wr, wc) = (-wr, -wc)
-
-tickBall :: Ball -> Ball
-tickBall b = b { pSpeed = tick (pSpeed b) }
-
-modPos :: Ball -> Ball
-modPos (Ball p t d@(dr, dc) (r, c)) = Ball p t d (r+dr, c+dc)
-
-isIn :: Dimensions -> Ball -> Bool
-isIn (w, h) (Ball p _ _ (pr, pc)) =
-            let (pw, ph) = planeSize p
-            in pr >= 1 &&
-               pr+ph-1 <= h &&
-               pc >= 1 &&
-               pc+pw-1 <= w
-
-dpart :: Ball -> (Coords, Plane)
-dpart (Ball p _ _ cs) = (cs, p)
-
-genBall :: StdGen -> Dimensions -> (Ball, StdGen)
-genBall g ds =
-                let (c, g1) = pickRandom [minBound..] g
-                    (s, g2) = getRandom (1, 3) g1
-                    (v, g3) = pickRandom dirs g2
-                    (p, g4) = ranIx ((1,1), T.swap ds) g3
-                    b = Ball (cell 'o' # color c Vivid)
-                             (creaBoolTimerLoop s) v p
-                in (b, g4)
-        where
-              dirs = [(1, 1), (1, -1), (-1, 1), (-1, -1)]
-
-              -- tuples instances are yet to be added to `random`
-              -- as nov 21; this will do meanwhile.
-              ranIx :: I.Ix a => (a, a) -> StdGen -> (a, StdGen)
-              ranIx r wg = pickRandom (I.range r) wg
-
--------------------------------------------------------------------------------
--- Timer
-
-type Timer = (Timed Bool, Integer)
-
-ctimer :: TPS -> Timer
-ctimer tps = (creaBoolTimerLoop tps, 0)
-
-ltimer :: Timer -> Timer
-ltimer (t, i) = let t' = tick t
-                    k = B.bool 0 1 (fetchFrame t')
-                in (t', i+k)
-
-dtimer :: Timer -> Plane
-dtimer (_, i) = word . show $ i
-
--------------------------------------------------------------------------------
--- Game
-
-data GState = GState { gen :: StdGen,
-                       quit :: Bool,
-                       timer :: Timer,
-                       balls :: [Ball],
-                       bslow :: Bool }
-            -- pSlow is not used in game, it is there just
-            -- for the test suite
-
-fireworks :: StdGen -> Game GState
-fireworks g = Game tps istate lfun dfun qfun
-    where
-          tps = 60
-
-          istate :: GState
-          istate = GState g False (ctimer tps) [] False
-
--------------------------------------------------------------------------------
--- Logic
-
-lfun :: GEnv -> GState -> Event -> GState
-lfun e s (KeyPress 's') =
-            let g = gen s
-                ds = eTermDims e
-                (b, g1) = genBall g ds
-            in s { gen = g1,
-                   balls = b : balls s }
-lfun _ s (KeyPress 'q') = s { quit = True }
-lfun _ s (KeyPress _)   = s
-lfun r s Tick           =
-            let ds = eTermDims r
-
-                ps = balls s
-                ps' = M.mapMaybe (modPar ds) ps
-
-                bs = eFPS r < 30
-            in s { timer = ltimer (timer s),
-                   balls = filter (isIn ds)  ps',
-                   bslow = bs }
-
-qfun :: GState -> Bool
-qfun s = quit s
-
--------------------------------------------------------------------------------
--- Draw
-
-dfun :: GEnv -> GState -> Plane
-dfun r s =             mergePlanes
-                         (uncurry blankPlane ds)
-                         (map dpart $ balls s) &
-            (1, 2) %^> tui # trans &
-            (1, 2) %.< inst # trans # bold
-    where
-          ds = eTermDims r
-          tm = timer s
-
-          tui :: Plane
-          tui = let fps = eFPS r
-                    np = length $ balls s
-
-                    l1 = word "FPS: " ||| word (show fps)
-                    l2 = word "Timer: " ||| dtimer tm
-                    l3 = word ("Balls: " ++ show np)
-                    l4 = word ("Term. dims.: " ++ show ds)
-                in vcat [l1, l2, l3, l4]
-
-          inst :: Plane
-          inst = word "Press (s) to spawn" ===
-                 word "Press (q) to quit"
-
-          trans :: Draw
-          trans = makeTransparent ' '

vendored/ansi-terminal-game-1.8.0.0/example/MainAlone.hs

@@ -1,12 +0,0 @@
-module Main where
-
-
-import Alone ( aloneInARoom, sizeCheck )
-
-import Terminal.Game
-
--- run with: cabal new-run -f examples alone
-
-main :: IO ()
-main = do sizeCheck
-          errorPress $ playGame aloneInARoom

vendored/ansi-terminal-game-1.8.0.0/example/MainBalls.hs

@@ -1,12 +0,0 @@
-module Main where
-
-import Balls
-
-import Terminal.Game
-
--- Balls Main module. The meat of the game is in `examples/Balls.hs`
-
-main :: IO ()
-main = getStdGen >>= \g ->
-       playGame (fireworks g)
-

vendored/ansi-terminal-game-1.8.0.0/example/MainHotReload.hs

@@ -1,31 +0,0 @@
-module Main where
-
-import Alone ( aloneInARoom, sizeCheck )
-
-import Terminal.Game
-
--- Hot reloading is a handy feature while writing a game. Here I will
--- show you how to do that with ansi-terminal-game.
---
--- 1. install `entr` from your repositories;
--- 2. run `find example/*.hs | entr -cr cabal run -f examples hot-reload`;
--- 3. now modify example/Alone.hs and see your changes live!
---
--- Caveat: entr and similar applications do *not* work with interactive
--- programs, so you need — as shown below — to load a record and play
--- it as a demo.
--- This is still useful to iteratively build NPCs’ behaviour, GUIs, etc.
---
--- Remember that you can use `recordGame` to record a session. If you
--- need something fancier for your game (e.g. hot-reload with input),
--- `venzone` [1] (module Watcher) has a builtin /watch mode/ you can
--- take inspiration from.
---
--- [1] https://hackage.haskell.org/package/venzone
-
-main :: IO ()
-main = do
-        sizeCheck
-        gr <- readRecord "test/records/alone-record-test.gr"
-                -- check `readRecord
-        () <$ narrateGame aloneInARoom gr

vendored/ansi-terminal-game-1.8.0.0/example/MainPlayback.hs

@@ -1,30 +0,0 @@
-module Main where
-
-import Alone ( aloneInARoom, sizeCheck )
-
-import Terminal.Game
-
-import System.IO.Temp ( emptySystemTempFile )
-
--- plays the game and, once you quit, shows a replay of the session
--- run with: cabal new-run -f examples alone-playback
-
-main :: IO ()
-main = do
-        sizeCheck
-        tf <- emptySystemTempFile "alone-record.gr"
-        playback tf
-
-playback :: FilePath -> IO ()
-playback f = do
-        prompt "Press <Enter> to play the game."
-        recordGame aloneInARoom f
-        prompt "Press <Enter> to watch playback."
-        es <- readRecord f
-        _ <- narrateGame aloneInARoom es
-        prompt "Playback over! Press <Enter> to quit."
-    where
-          prompt :: String -> IO ()
-          prompt s = putStrLn s >> () <$ getLine
-
-

vendored/ansi-terminal-game-1.8.0.0/platform-dep/non-win/Terminal/Game/Utils.hs

@@ -1,14 +0,0 @@
---------------------------------------------------------------------------------
--- Nonbuffering getChar
--- 2017 Francesco Ariis GPLv3                                             80cols
---------------------------------------------------------------------------------
-
-module Terminal.Game.Utils ( inputCharTerminal,
-                             isWin32Console )
-                           where
-
-inputCharTerminal :: IO Char
-inputCharTerminal = getChar
-
-isWin32Console :: IO Bool
-isWin32Console = return False

vendored/ansi-terminal-game-1.8.0.0/platform-dep/windows/Terminal/Game/Utils.hs

@@ -1,29 +0,0 @@
---------------------------------------------------------------------------------
--- Nonbuffering getChar et al
--- 2017 Francesco Ariis GPLv3                                             80cols
---------------------------------------------------------------------------------
-{-# LANGUAGE ForeignFunctionInterface #-}
-
--- horrible horrible horrible hack to make unbuffered input
--- work on Windows (and win32console check)
-
-module Terminal.Game.Utils (inputCharTerminal,
-                            isWin32Console )
-                           where
-
-import qualified Data.Char             as C
-import qualified Foreign.C.Types       as FT
-import qualified System.Console.MinTTY as M
-
-inputCharTerminal :: IO Char
-inputCharTerminal = getCharWindows
-
--- no idea why, but unsafe breaks it
-getCharWindows :: IO Char
-getCharWindows = fmap (C.chr . fromEnum) c_getch
-foreign import ccall safe "conio.h getch"
-  c_getch :: IO FT.CInt
-
--- not perfect, but it is what it is (on win, non minTTY)
-isWin32Console :: IO Bool
-isWin32Console = not <$> M.isMinTTY

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game.hs

@@ -1,206 +0,0 @@
--------------------------------------------------------------------------------
--- |
--- Module      :  Terminal.Game
--- Copyright   :  © 2017-2021 Francesco Ariis
--- License     :  GPLv3 (see COPYING file)
---
--- Maintainer  :  Francesco Ariis <fa-ml@ariis.it>
--- Stability   :  provisional
--- Portability :  portable
---
--- Machinery and utilities for 2D terminal games.
---
--- New? Start from 'Game'.
---
--------------------------------------------------------------------------------
-
--- Basic col-on-black ASCII terminal, operations.
--- Only module to be imported.
-
-module Terminal.Game ( -- * Running
-                       TPS,
-                       FPS,
-                       Event(..),
-                       GEnv(..),
-                       Game,
-                       GameT(..),
-                       playGame,
-                       playGameT,
-                       ATGException(..),
-
-                       -- ** Helpers
-                       playGameS,
-                       Terminal.Game.displaySize,
-                       assertTermDims,
-                       errorPress,
-                       blankPlaneFull,
-                       centerFull,
-                       cleanAndExit,
-
-                       -- * Game logic
-                       -- | Some convenient function dealing with
-                       -- Timers ('Timed') and 'Animation's.
-                       --
-                       -- Usage of these is not mandatory: 'Game' is
-                       -- parametrised over any state @s@, you are free
-                       -- to implement game logic as you prefer.
-
-                       -- ** Timers/Animation
-
-                       -- *** Timers
-                       Timed,
-                       creaTimer, creaBoolTimer,
-                       creaTimerLoop, creaBoolTimerLoop,
-
-                       -- *** Animations
-                       Animation,
-                       creaAnimation,
-                       creaLoopAnimation,
-
-                       -- *** T/A interface
-                       tick, ticks, reset, lapse,
-                       fetchFrame, isExpired,
-
-                       -- ** Random numbers
-                       StdGen,
-                       getStdGen, mkStdGen,
-                       getRandom, pickRandom,
-                       UniformRange,
-
-                       -- * Drawing
-                       -- | To get to the gist of drawing, check the
-                       -- documentation for '%'.
-                       --
-                       -- Blitting on screen is double-buffered and diff'd
-                       -- (at each frame, only cells with changed character
-                       -- will be redrawn).
-
-                       -- ** Plane
-                       Plane,
-                       Dimensions,
-                       Coords,
-                       Row, Column,
-                       Width, Height,
-                       blankPlane,
-                       stringPlane,
-                       stringPlaneTrans,
-                       makeTransparent,
-                       makeOpaque,
-                       planePaper,
-                       planeSize,
-
-                       -- ** Draw
-                       Draw,
-                       (%), (&), (#),
-                       subPlane,
-                       mergePlanes,
-                       cell, word, box,
-                       Color(..), ColorIntensity(..),
-                       color, bold, invert,
-
-                       -- *** Alternative origins
-                       -- $origins
-                       (%^>), (%.<), (%.>),
-
-                       -- *** Text boxes
-                       textBox, textBoxLiquid,
-                       textBoxHyphen, textBoxHyphenLiquid,
-                       Hyphenator,
-                       -- | Eurocentric convenience reexports. Check
-                       -- "Text.Hyphenation.Language" for more languages.
-                       english_GB, english_US, esperanto,
-                       french, german_1996, italian, spanish,
-
-                       -- *** Declarative drawing
-                       (|||), (===), (***), hcat, vcat,
-
-                       -- * Testing
-                       GRec,
-                       recordGame,
-                       readRecord,
-                       testGame,
-                       setupGame,
-                       narrateGame,
-
-                       -- * Transformers
-                       GameIO(..),
-                       Test(..),
-                       Narrate(..)
-
-                       -- | A quick and dirty way to have /hot reload/
-                       -- (autorestarting your game when source files change)
-                       -- is illustrated in @example/MainHotReload.hs@.
-
-                       -- * Cross platform
-                       -- $xcompat
-                     )
-    where
-
-import System.Console.ANSI
-import Terminal.Game.Animation
-import Terminal.Game.Draw
-import Terminal.Game.Layer.Imperative
-import Terminal.Game.Layer.Object as O
-import Terminal.Game.Layer.Object.IO ( cleanAndExit )
-import Terminal.Game.Plane
-import Terminal.Game.Random
-import Text.LineBreak
-
-import qualified Control.Monad as CM
-
--- $origins
--- Placing a plane is sometimes more convenient if the coordinates origin
--- is a corner other than top-left (e.g. “Paste this plane one row from
--- bottom-left corner”). These combinators — meant to be used instead of '%'
--- — allow you to do so. Example:
---
--- @
--- prova :: Plane
--- prova = let rect = box 6 3  \'.\'
---             letters = word "ab"
---         in            rect &
---            (1, 1) %.> letters         -- start from bottom-right
---
---     -- λ> putStr (planePaper prova)
---     -- ......
---     -- ......
---     -- ....ab
--- @
-
--- $xcompat
--- Good practices for cross-compatibility:
---
--- * choose game dimensions of no more than __24 rows__ and __80 columns__.
---   This ensures compatibility with the trickiest terminals (i.e. Win32
---   console);
---
--- * use __ASCII characters__ only. Again this is for Win32 console
---   compatibility, until
---   [this GHC bug](https://gitlab.haskell.org/ghc/ghc/issues/7593) gets
---   fixed;
---
--- * employ colour sparingly: as some users will play your game in a
---   light-background terminal and some in a dark one, choose only colours
---   that go well with either (blue, red, etc.);
---
--- * some terminals/multiplexers (i.e. tmux) do not make a distinction
---   between vivid/dull; do not base your game mechanics on that
---   difference.
-
--- | /Usable/ terminal display size (on Win32 console the last line is
--- set aside for input). Throws 'CannotGetDisplaySize' on error.
-displaySize :: IO Dimensions
-displaySize = O.displaySizeErr
-
--- | Check if terminal can accomodate 'Dimensions', otherwise throws
--- 'DisplayTooSmall' with a helpful message for the player.
-assertTermDims :: Width -> Height -> IO ()
-assertTermDims dw dh =
-            clearScreen >>
-            setCursorPosition 0 0 >>
-            displaySizeErr >>= \ads ->
-            CM.when (isSmaller ads)
-                    (throwExc $ DisplayTooSmall (dw, dh) ads)
-    where
-          isSmaller :: Dimensions -> Bool
-          isSmaller (ww, wh) = ww < dw || wh < dh

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Animation.hs

@@ -1,33 +0,0 @@
--------------------------------------------------------------------------------
--- Animation
--- 2018 Francesco Ariis GPLv3
--------------------------------------------------------------------------------
-
--- {-# LANGUAGE DeriveGeneric #-}
--- {-# LANGUAGE DefaultSignatures #-}
--- {-# LANGUAGE StandaloneDeriving #-}
--- {-# LANGUAGE FlexibleInstances #-}
-
-module Terminal.Game.Animation (module Terminal.Game.Animation,
-                                module T
-                               ) where
-
-import Terminal.Game.Plane
-
-import Control.Timer.Tick as T
-
--- import Data.Serialize
-
--- import qualified Data.ByteString as BS
--- import qualified Data.Bifunctor as BF
-
--- | An @Animation@ is a series of timed time-separated 'Plane's.
-type Animation = T.Timed Plane
-
--- | Creates an 'Animation'.
-creaAnimation :: [(Integer, Plane)] -> Animation
-creaAnimation ips = creaTimedRes (Times 1 Elapse) ips
-
--- | Creates a looped 'Animation'.
-creaLoopAnimation :: [(Integer, Plane)] -> Animation
-creaLoopAnimation ips = creaTimedRes AlwaysLoop ips

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Character.hs

@@ -1,43 +0,0 @@
-module Terminal.Game.Character where
-
-import Data.Char        as C
-import Text.Unidecode   as D
-import System.IO.Unsafe as U
-
-
-import Terminal.Game.Utils
-
--- Non ASCII character still cause crashes on Win32 console (see this
--- report: https://gitlab.haskell.org/ghc/ghc/issues/7593 ).
--- We provide a function to substitute them when playing on Win32
--- console, with another appropriate chatacter.
-
-win32SafeChar :: Char -> Char
-win32SafeChar c | areWeWin32 = toASCII c
-                | otherwise  = c
-    where
-          areWeWin32 :: Bool
-          areWeWin32 = unsafePerformIO isWin32Console
-
--- ANCILLARIES --
-
-toASCII :: Char -> Char
-toASCII c | C.isAscii c         = c
-          | Just cm <- lu       = cm    -- hand-made substitution
-          | [cu] <- unidecode c = cu    -- unidecode
-          | otherwise           = '?'   -- all else failing
-    where
-          lu = lookup c subDictionary
-
-subDictionary :: [(Char, Char)]
-subDictionary = [ -- various open/close quotes
-                  ('«', '<'),
-                  ('»', '>'),
-                  ('“', '\''),
-                  ('”', '\''),
-                  ('‘', '\''),
-                  ('’', '\''),
-
-                  -- typographical marks
-                  ('—', '-') ]
-

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Draw.hs

@@ -1,255 +0,0 @@
--------------------------------------------------------------------------------
--- Print convenience functions
--- 2017 Francesco Ariis GPLv3
--------------------------------------------------------------------------------
-
--- Drawing primitives. If not stated otherwise (textbox, etc.), ' ' are
--- assumed to be opaque
-
-module Terminal.Game.Draw (module Terminal.Game.Draw,
-                           (F.&)
-                          ) where
-
-import Terminal.Game.Plane
-
-import Text.LineBreak
-
-import qualified Data.Function       as F ( (&) )
-import qualified Data.List           as L
-import qualified System.Console.ANSI as CA
-
-
------------
--- TYPES --
------------
-
--- | A drawing function, usually executed with the help of '%'.
-type Draw = Plane -> Plane
-
-
------------------
--- COMBINATORS --
------------------
-
--- | Pastes one 'Plane' onto another. To be used along with 'F.&'
--- like this:
---
--- @
---  d :: Plane
---  d =          blankPlane 100 100  &
---      (3, 4) % box '_' 3 5         &
---      (a, b) % cell \'A\' '#' bold
--- @
-(%) :: Coords -> Plane -> Draw
-cds % p1 = \p2 -> pastePlane p1 p2 cds
-infixl 4 %
-
--- | Apply style to plane, e.g.
---
--- > cell 'w' # bold
-(#) :: Plane -> Draw -> Plane
-p # sf = sf p
-infixl 8 #
-
--- | Shorthand for sequencing 'Plane's, e.g.
---
--- @
---           firstPlane  &
---  (3, 4) '%' secondPlane &
---  (1, 9) '%' thirdPlane
--- @
---
--- is equal to
---
--- @
---  mergePlanes firstPlane [((3,4), secondPlane),
---                          ((1,9), thirdPlane)]
--- @
-mergePlanes :: Plane -> [(Coords, Plane)] -> Plane
-mergePlanes p cps = L.foldl' addPlane p cps
-    where
-          addPlane :: Plane -> (Coords, Plane) -> Plane
-          addPlane bp (cs, tp) = bp F.& cs % tp
-
--- | Place two 'Plane's side-by-side, horizontally.
-(|||) :: Plane -> Plane -> Plane
-(|||) a b = let (wa, ha) = planeSize a
-                (wb, hb) = planeSize b
-            in mergePlanes (blankPlane (wa + wb) (max ha hb))
-                           [((1,1),    a),
-                            ((1,wa+1), b)]
-
--- | Place two 'Plane's side-by-side, vertically.
-(===) :: Plane -> Plane -> Plane
-(===) a b = let (wa, ha) = planeSize a
-                (wb, hb) = planeSize b
-            in mergePlanes (blankPlane (max wa wb) (ha + hb))
-                           [((1,1),    a),
-                            ((ha+1,1), b)]
-
--- | @a *** b@ blits @b@ in the centre of @a@.
-(***) :: Plane -> Plane -> Plane
-(***) a b = let (aw, ah) = planeSize a
-                (bw, bh) = planeSize b
-                r = quot (ah - bh) 2 + 1
-                c = quot (aw - bw) 2 + 1
-            in           a F.&
-                (r, c) % b
-
-
--- | Place a list of 'Plane's side-by-side, horizontally. @error@s on
--- empty list.
-hcat :: [Plane] -> Plane
-hcat [] = blankPlane 1 1 # makeTransparent ' '
-hcat ps = L.foldl1' (|||) ps
-
--- | Place a list of 'Plane's side-by-side, vertically. @error@s on
--- empty list.
-vcat :: [Plane] -> Plane
-vcat [] = blankPlane 1 1 # makeTransparent ' '
-vcat ps = L.foldl1' (===) ps
-
-infixl 6 |||, ===, ***
-
-
-------------
--- STYLES --
-------------
-
--- | Set foreground color.
-color :: CA.Color -> CA.ColorIntensity -> Plane -> Plane
-color c i p = mapPlane (colorCell c i) p
-
--- | Apply bold style to 'Plane'.
-bold :: Plane -> Plane
-bold p = mapPlane boldCell p
-
--- | Swap foreground and background colours of 'Plane'.
-invert :: Plane -> Plane
-invert p = mapPlane reverseCell p
-
-
-
--------------
--- DRAWING --
--------------
-
--- | A box of dimensions @w h@.
-box :: Width -> Height -> Char -> Plane
-box w h chr = seqCellsDim w h cells
-    where
-          cells = [((r, c), chr) | r <- [1..h], c <- [1..w]]
-
--- | A 1×1 @Plane@.
-cell :: Char -> Plane
-cell ch = box 1 1 ch
-
--- | @1xn@ 'Plane' with a word in it. If you need to import multiline
--- ASCII art, check 'stringPlane' and 'stringPlaneTrans'.
-word :: String -> Plane
-word w = seqCellsDim (L.genericLength w) 1 cells
-    where
-          cells = zip (zip (repeat 1) [1..]) w
-
--- opaque :: Plane -> Plane
--- opaque p = pastePlane p (box ' ' White w h) (1, 1)
---     where
---           (w, h) = pSize p
-
--- | A text-box. Assumes @' '@s are transparent.
-textBox :: Width -> Height -> String -> Plane
-textBox w h cs = frameTrans w h (textBoxLiquid w cs)
-
--- | Like 'textBox', but tall enough to fit @String@.
-textBoxLiquid :: Width -> String -> Plane
-textBoxLiquid w cs = textBoxGeneralLiquid Nothing w cs
-
--- | As 'textBox', but hypenated. Example:
---
--- @
--- (normal textbox)                        (hyphenated textbox)
--- Rimasi un po’ a meditare nel buio       Rimasi un po’ a meditare nel buio
--- velato appena dal barlume azzurrino     velato appena dal barlume azzurrino
--- del fornello a gas, su cui              del fornello a gas, su cui sobbol-
--- sobbolliva quieta la pentola.           liva quieta la pentola.
--- @
---
--- Notice how in the right box /sobbolliva/ is broken in two. This
--- can be useful and aesthetically pleasing when textboxes are narrow.
-textBoxHyphen :: Hyphenator -> Width -> Height -> String -> Plane
-textBoxHyphen hp w h cs = frameTrans w h (textBoxHyphenLiquid hp w cs)
-
--- | As 'textBoxLiquid', but hypenated.
-textBoxHyphenLiquid :: Hyphenator -> Width -> String -> Plane
-textBoxHyphenLiquid h w cs = textBoxGeneralLiquid (Just h) w cs
-
-textBoxGeneralLiquid :: Maybe Hyphenator -> Width -> String -> Plane
-textBoxGeneralLiquid mh w cs = transparent
-    where
-          -- hypenathion
-          bf  = BreakFormat (fromIntegral w) 4 '-' mh
-          hcs = breakStringLn bf cs
-          h   = L.genericLength hcs
-
-          f :: [String] -> [(Coords, Char)]
-          f css = concatMap (uncurry rf) (zip [1..] css)
-              where rf :: Int -> String -> [(Coords, Char)]
-                    rf cr ln = zip (zip (repeat cr) [1..]) ln
-
-          out         = seqCellsDim w h (f hcs)
-          transparent = makeTransparent ' ' out
-
-
-----------------------------
--- ADDITIONAL COMBINATORS --
-----------------------------
-
--- Coords as if origin were @ bottom-right
-recipCoords :: Coords -> Plane -> Plane -> Coords
-recipCoords (r, c) p p1 =
-            let (pw, ph) = planeSize p
-                (p1w, p1h) = planeSize p1
-                r' = ph-p1h-r+2
-                c' = pw-p1w-c+2
-            in (r', c')
-
--- | Pastes a plane onto another (origin: top-right).
-(%^>) :: Coords -> Plane -> Draw
-(r, c) %^> p1 = \p ->
-            let (_, c') = recipCoords (r, c) p p1
-            in p F.& (r, c') % p1
-
--- | Pastes a plane onto another (origin: bottom-left).
-(%.<) :: Coords -> Plane -> Draw
-(r, c) %.< p1 = \p ->
-            let (r', _) = recipCoords (r, c) p p1
-            in p F.& (r', c) % p1
-
--- | Pastes a plane onto another (origin: bottom-right).
-(%.>) :: Coords -> Plane -> Draw
-cs %.> p1 = \p ->
-            let (r', c') = recipCoords cs p p1
-            in p F.& (r', c') % p1
-
-infixl 4 %^>
-infixl 4 %.<
-infixl 4 %.>
-
-
------------------
--- ANCILLARIES --
------------------
-
-seqCellsDim :: Width -> Height -> [(Coords, Char)] -> Plane
-seqCellsDim w h cells = seqCells (blankPlane w h) cells
-
-seqCells :: Plane -> [(Coords, Char)] -> Plane
-seqCells p cells = updatePlane p (map f cells)
-    where
-          f (cds, chr) = (cds, creaCell chr)
-
--- paste plane on a blank one, and make ' ' transparent
-frameTrans :: Width -> Height -> Plane -> Plane
-frameTrans w h p = let bt = makeTransparent ' ' (blankPlane w h)
-                   in bt F.& (1, 1) % p
-

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Imperative.hs

@@ -1,269 +0,0 @@
--------------------------------------------------------------------------------
--- Layer 1 (imperative), as per
--- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html
--- 2019 Francesco Ariis GPLv3
--------------------------------------------------------------------------------
-
-{-# Language ScopedTypeVariables #-}
-{-# Language RankNTypes #-}
-
-module Terminal.Game.Layer.Imperative where
-
-import Terminal.Game.Draw
-import Terminal.Game.Layer.Object
-
-import qualified Control.Concurrent as CC
-import qualified Control.Exception as E
-import qualified Control.Monad as CM
-import qualified Control.Monad.Trans          as T
-import qualified Data.Bool as B
-import qualified Data.List as D
-import qualified System.IO as SI
-
-import Terminal.Game.Plane
-
-type Game s = GameT IO s
-
--- | Game definition datatype, parametrised on your gamestate. The two most
--- important elements are the function dealing with logic and the drawing
--- one. Check @alone@ demo (@cabal run -f examples alone@) to see a simple
--- game in action.
-data GameT m s =
-        Game { gTPS           :: TPS,
-                    -- ^ Game speed in ticks per second. You do not
-                    -- need high values, since the 2D canvas is coarse
-                    -- (e.g. 13 TPS is enough for action games).
-               gInitState     :: s,   -- ^ Initial state of the game.
-               gLogicFunction :: GEnv -> s -> Event -> m s,
-                         -- ^ Logic function.
-               gDrawFunction  :: GEnv -> s -> Plane,
-                         -- ^ Draw function. Just want to blit your game
-                         -- in the middle? Check 'centerFull'.
-               gQuitFunction  :: s -> Bool
-                         -- ^ /Should I quit?/ function.
-                                      }
-
--- | A blank plane as big as the terminal.
-blankPlaneFull :: GEnv -> Plane
-blankPlaneFull e = uncurry blankPlane (eTermDims e)
-
--- | Blits plane in the middle of terminal.
---
--- @
---   draw :: GEnv -> MyState -> Plane
---   draw ev s =
---       centerFull ev $
---         ⁝
--- @
-centerFull :: GEnv -> Plane -> Plane
-centerFull e p = blankPlaneFull e *** p
-
--- | Entry point for the game execution, should be called in @main@.
---
--- You __must__ compile your programs with @-threaded@; if you do not do
--- this the game will crash at start-up. Just add:
---
--- @
--- ghc-options:      -threaded
--- @
---
--- in your @.cabal@ file and you will be fine!
---
--- Need to inspect state on exit? Check 'playGameS'.
-playGame :: Game s -> IO ()
-playGame g = () <$ playGameT T.liftIO g
-
-playGameT :: Monad m => (forall m1 a. T.MonadIO m1 => m a -> m1 a) -> GameT m s -> IO s
-playGameT trans g = runGameGeneral trans g
-
--- | As 'playGame', but do not discard state.
-playGameS :: Game s -> IO s
-playGameS g = playGameT T.liftIO g
-
--- | Tests a game in a /pure/ environment. Aims to accurately emulate 'GEnv'
--- changes (screen size, FPS) too.
-testGame :: GameT Test s -> GRec -> s
-testGame g ts = fst $ runTest (runGameGeneral id g) ts
-
--- | As 'testGame', but returns 'Game' instead of a bare state.
--- Useful to fast-forward (e.g.: skip menus) before invoking 'playGame'.
-setupGame :: GameT Test s -> GRec -> GameT Test s
-setupGame g ts = let s' = testGame g ts
-                 in g { gInitState = s' }
-                 -- xx qua messi solo [Event]?
-
--- | Similar to 'testGame', runs the game given a 'GRec'. Unlike
--- 'testGame', the playthrough will be displayed on screen. Useful when a
--- test fails and you want to see how.
---
--- See this in action with  @cabal run -f examples alone-playback@.
---
--- Notice that 'GEnv' will be provided at /run-time/, and not
--- record-time; this can make emulation slightly inaccurate if — e.g. —
--- you replay the game on a smaller terminal than the one you recorded
--- the session on.
-narrateGame :: GameT Narrate s -> GRec -> IO s
-narrateGame g e = runReplay (runGameGeneral id g) e
-
--- | Play as in 'playGame' and write the session to @file@. Useful to
--- produce input for 'testGame' and 'narrateGame'. Session will be
--- recorded even if an exception happens while playing.
-recordGame :: GameT Record s -> FilePath -> IO ()
-recordGame g fp =
-        E.bracket
-          (CC.newMVar igrec)
-          (\ve -> writeRec fp ve)
-          (\ve -> () <$ runRecord (runGameGeneral id g) ve)
-
-data Config = Config { cMEvents :: CC.MVar [Event],
-                       cTPS     :: TPS }
-
-runGameGeneral :: forall s m1 m. (Monad m1, MonadGameIO m)
-               => (forall a. m1 a -> m a)
-               -> GameT m1 s
-               -> m s
-runGameGeneral trans (Game tps s lf df qf) =
-            -- init
-            setupDisplay    >>
-            startEvents tps >>= \(InputHandle ve ts) ->
-            displaySizeErr  >>= \ds -> do
-
-            -- do it!
-            let c = Config ve tps
-            s' <- (game c ds) `onException` (stopEvents ts >> shutdownDisplay)
-            stopEvents ts
-            return s'
-    where
-          game :: MonadGameIO m => Config -> Dimensions -> m s
-          game c wds = gameLoop trans c s lf df qf
-                                Nothing wds
-                                (creaFPSCalc tps)
-
--- | Wraps an @IO@ computation so that any 'ATGException' or 'error' gets
--- displayed along with a @\<press any key to quit\>@ prompt.
--- Some terminals shut-down immediately upon program end; adding
--- @errorPress@ to 'playGame' makes it easier to beta-test games on those
--- terminals.
-errorPress :: IO a -> IO a
-errorPress m = E.catches m [E.Handler errorDisplay,
-                            E.Handler atgDisplay]
-    where
-          errorDisplay :: E.ErrorCall -> IO a
-          errorDisplay (E.ErrorCallWithLocation cs l) = report $
-              putStrLn (cs ++ "\n\n")        >>
-              putStrLn "Stack trace info:\n" >>
-              putStrLn l
-
-          atgDisplay :: ATGException -> IO a
-          atgDisplay e = report $ print e
-
-          report :: IO () -> IO a
-          report wm =
-              putStrLn "ERROR REPORT\n"                >>
-              wm                                       >>
-              putStrLn "\n\n <Press any key to quit>"  >>
-              SI.hSetBuffering SI.stdin SI.NoBuffering >>
-              getChar                                  >>
-              errorWithoutStackTrace "errorPress"
-
-
------------
--- LOGIC --
------------
-
--- from http://www.loomsoft.net/resources/alltut/alltut_lesson6.htm
-gameLoop :: (Monad m1, MonadGameIO m) =>
-            (forall a. m1 a -> m a) ->
-            Config            -> -- event source
-            s                 -> -- state
-            (GEnv ->
-             s -> Event -> m1 s) -> -- logic function
-            (GEnv ->
-             s -> Plane)      -> -- draw function
-            (s -> Bool)       -> -- quit? function
-            Maybe Plane       -> -- last blitted screen
-            Dimensions        -> -- Term dimensions
-            FPSCalc           -> -- calculate fps
-            m s
-gameLoop trans c s lf df qf opln td fps =
-
-        -- quit?
-        checkQuit qf s >>= \qb ->
-        if qb
-          then return s
-        else
-
-        -- fetch events (if any)
-        pollEvents (cMEvents c) >>= \es ->
-
-        -- no events? skip everything
-        if null es
-          then sleepABit (cTPS c)               >>
-               gameLoop trans c s lf df qf opln td fps
-        else
-
-        displaySizeErr            >>= \td' ->
-
-        -- logic
-        let ge = GEnv td' (calcFPS fps) in
-        trans (stepsLogic s (lf ge) es) >>= \(i, s') ->
-
-        -- no `Tick` events? You do not need to blit, just update state
-        if i == 0
-          then gameLoop trans c s' lf df qf opln td fps
-        else
-
-        -- FPS calc
-        let fps' = addFPS i fps in
-
-        -- clear screen if resolution changed
-        let resc = td /= td' in
-        CM.when resc clearDisplay >>
-
-        -- draw
-        let opln' | resc = Nothing -- res changed? restart double buffering
-                  | otherwise = opln
-            npln = df ge s' in
-
-        blitPlane opln' npln >>
-
-        gameLoop trans c s' lf df qf (Just npln) td' fps'
-
--- Int = number of `Tick` events
-stepsLogic :: Monad m => s -> (s -> Event -> m s) -> [Event] -> m (Integer, s)
-stepsLogic s lf es = do
-  let ies = D.genericLength . filter isTick $ es
-  res <- CM.foldM lf s es
-  return (ies, res)
- where
-  isTick Tick = True
-  isTick _    = False
-
--------------------------------------------------------------------------------
--- Frame per Seconds
-
-data FPSCalc = FPSCalc [Integer] TPS
-    -- list with number of `Ticks` processed at each blit and expected
-    -- FPS (i.e. TPS)
-
--- the size of moving average will be TPS (that simplifies calculations)
-creaFPSCalc :: TPS -> FPSCalc
-creaFPSCalc tps = FPSCalc (D.genericReplicate tps {- (tps*2) -} 1) tps
-    -- tps*1: size of thw window in **blit actions** (not tick actions!)
-    --        so keeping it small should be responsive and non flickery
-    --        at the same time!
-
--- add ticks
-addFPS :: Integer -> FPSCalc -> FPSCalc
-addFPS nt (FPSCalc (_:fps) tps) = FPSCalc (fps ++ [nt]) tps
-addFPS _ (FPSCalc [] _) = error "addFPS: empty list."
-
-calcFPS :: FPSCalc -> Integer
-calcFPS (FPSCalc fps tps) =
-        let ts = sum fps
-            ds = D.genericLength fps
-        in roundQuot (tps * ds) ts
-    where
-          roundQuot :: Integer -> Integer -> Integer
-          roundQuot a b = let (q, r) = quotRem a b
-                          in q + B.bool 0 1 (r > div b 2)

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object.hs

@@ -1,30 +0,0 @@
--------------------------------------------------------------------------------
--- Layer 2 (mockable IO), as per
--- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html
--- 2019 Francesco Ariis GPLv3
--------------------------------------------------------------------------------
-
-module Terminal.Game.Layer.Object ( module Export ) where
-
-import Terminal.Game.Layer.Object.Interface as Export
-import Terminal.Game.Layer.Object.GameIO    as Export
-import Terminal.Game.Layer.Object.Narrate   as Export
-import Terminal.Game.Layer.Object.Primitive as Export
-import Terminal.Game.Layer.Object.Record    as Export
-import Terminal.Game.Layer.Object.Test      as Export
-
--- DESIGN NOTES --
-
--- The classes are described in 'Interface'.
-
--- The implemented monads are four:
---     - GameIO (via MonadIO): playing the game
---     - Test: testing the game in a pure manner
---     - Record: playing the game and record the Events in a file
---     - Replay: replay a game using a set of Events.
---
--- The last two monads (Record/Replay) take advantage of "overlapping
--- instances". Instead of reimplementing most of what happens in MonadIO,
--- they'll just touch the classes from interface which behaviour they
--- will modify; being more specific, they will be chosen instead of plain
--- IO.

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/GameIO.hs

@@ -1,21 +0,0 @@
--------------------------------------------------------------------------------
--- Layer 2 (mockable IO), as per
--- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html
--- 2019 Francesco Ariis GPLv3
--------------------------------------------------------------------------------
-
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-
-module Terminal.Game.Layer.Object.GameIO where
-
-import qualified Control.Monad.Catch          as MC
-import qualified Control.Monad.Trans          as T
-
-
-newtype GameIO a = GameIO { runGIO :: IO a }
-                 deriving (Functor, Applicative, Monad,
-                           T.MonadIO,
-                           MC.MonadThrow, MC.MonadCatch, MC.MonadMask)
-
-

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/IO.hs

@@ -1,291 +0,0 @@
--------------------------------------------------------------------------------
--- Layer 2 (mockable IO), as per
--- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html
--- 2019 Francesco Ariis GPLv3
--------------------------------------------------------------------------------
-
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-
-module Terminal.Game.Layer.Object.IO where
-
-import Terminal.Game.Utils
-
-import Terminal.Game.Layer.Object.Interface
-import Terminal.Game.Layer.Object.Primitive
-import Terminal.Game.Plane
-
-import qualified Control.Concurrent           as CC
-import qualified Control.Monad                as CM
-import qualified Control.Monad.Catch          as MC
-import qualified Control.Monad.Trans          as T
-import qualified Data.List.Split              as LS
-import qualified System.Clock                 as SC
-import qualified System.Console.ANSI          as CA
-import qualified System.Console.Terminal.Size as TS
-import qualified System.IO                    as SI
-
--- Most General MonadIO operations.
-
-----------------
--- Game input --
-----------------
-
-instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) => MonadInput m where
-    startEvents tps = T.liftIO $ startIOInput tps
-    pollEvents ve = T.liftIO $ CC.swapMVar ve []
-    stopEvents ts = T.liftIO $ stopEventsIO ts
-
--- filepath = logging
-startIOInput :: TPS -> IO InputHandle
-startIOInput tps =
-            SI.hSetBuffering SI.stdin SI.NoBuffering  >>
-            SI.hSetBuffering SI.stdout SI.NoBuffering >>
-            SI.hSetEcho SI.stdin False                >>
-                -- all the buffering settings has to happen
-                -- at the top of startIOInput. If i move
-                -- them to display, you need to press enter
-                -- before playing the game on some machines.
-
-            -- event and log variables
-            CC.newMVar [] >>= \ve ->
-
-            getTimeTick tps               >>= \it ->
-            CC.forkIO (addTick ve tps it) >>= \te ->
-            CC.forkIO (addKeypress ve)    >>= \tk ->
-            return (InputHandle ve [te, tk])
-
--- a precise timer, not based on `threadDelay`
-type Elapsed = Integer -- in `Ticks`
-
--- elapsed from Epoch in ticks
-getTimeTick :: TPS -> IO Elapsed
-getTimeTick tps =
-        getTime >>= \tm ->
-        let ns = 10 ^ (9 :: Integer)
-            t1 = quot ns tps in
-        return (quot tm t1)
-
--- mr: maybe recording
-addTick :: CC.MVar [Event] -> TPS -> Elapsed -> IO ()
-addTick ve tps el =
-                -- precise timing. With `treadDelay`, on finer TPS,
-                -- ticks take too much (check threadDelay doc).
-                getTimeTick tps                   >>= \t ->
-                CM.replicateM_ (fromIntegral $ t-el)
-                               (addEvent ve Tick) >>
-
-                -- sleep some
-                sleepABit tps >>
-                addTick ve tps t
-
--- get action char
--- mr: maybe recording
-addKeypress :: CC.MVar [Event] -> IO ()
-addKeypress ve = -- vedi platform-dep/
-                 inputCharTerminal        >>= \c ->
-                 addEvent ve (KeyPress c) >>
-                 addKeypress ve
-
--- mr: maybe recording
-addEvent :: CC.MVar [Event] -> Event -> IO ()
-addEvent ve e = vf ve
-    where
-          vf d = CC.modifyMVar_ d (return . (++[e]))
-
-stopEventsIO :: [CC.ThreadId] -> IO ()
-stopEventsIO ts = mapM_ CC.killThread ts
-
------------------
--- Game timing --
------------------
-
-instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) => MonadTimer m where
-    getTime = T.liftIO $ SC.toNanoSecs <$> SC.getTime SC.Monotonic
-    sleepABit tps = T.liftIO $
-        CC.threadDelay (fromIntegral $ quot oneTickSec (tps*10))
-
---------------------
--- Error handling --
---------------------
-
-instance {-# OVERLAPS #-}
-        (Monad m, T.MonadIO m, MC.MonadMask m, MC.MonadThrow m) =>
-          MonadException m where
-    cleanUpErr m c = MC.finally m c
-    onException m c = MC.onException m c
-    throwExc t = MC.throwM t
-
------------
--- Logic --
------------
-
-instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) =>
-          MonadLogic m where
-    checkQuit fb s = return (fb s)
-
--------------
--- Display --
--------------
-
-instance {-# OVERLAPS #-} (Monad m, T.MonadIO m) => MonadDisplay m where
-    setupDisplay = T.liftIO initPart
-    clearDisplay = T.liftIO clearScreen
-    displaySize = T.liftIO displaySizeIO
-    blitPlane mp p = T.liftIO (blitPlaneIO mp p)
-    shutdownDisplay = T.liftIO cleanAndExit
-
-displaySizeIO :: IO (Maybe Dimensions)
-displaySizeIO =
-        TS.size        >>= \ts ->
-            -- cannot use ansi-terminal, on Windows you get
-            -- "ConsoleException 87" (too much scrolling)
-            -- and it does not work for mintty and it is
-            -- inefficient as it gets (attempts to scroll past
-            -- bottom right)
-        isWin32Console >>= \bw ->
-
-        return (fmap (f bw) ts)
-    where
-          f :: Bool -> TS.Window Int -> Dimensions
-          f wbw (TS.Window h w) =
-                let h' | wbw       = h - 1
-                       | otherwise = h
-                in (w, h')
-
--- pn: new plane, po: old plane
--- wo, ho: dimensions of the terminal. If they change, reinit double buffering
-blitPlaneIO :: Maybe Plane -> Plane -> IO ()
-blitPlaneIO mpo pn =
-
-        -- remember that Nothing will be passed:
-        -- - at the beginning of the game (first blit)
-        -- - when resolution changes (see gameLoop)
-        -- so do not duplicate hasResChanged checks here!
-
-        -- old plane
-        let
-            (pw, ph) = planeSize pn
-            bp  = blankPlane pw ph
-            po  = pastePlane (maybe bp id mpo) bp (1, 1)
-        in
-
-        -- new plane
-        let pn'  = pastePlane pn bp (1, 1)
-        in
-
-            -- trimming is foundamental, as blitMap could otherwise print
-            -- outside terminal boundaries and scroll to its death
-            -- (error 87 on Win32 console).
-
-        CA.setSGR [CA.Reset] >>
-        blitMap po pn'
-
-
------------------
--- ANCILLARIES --
------------------
-
-initPart :: IO ()
-initPart = -- check thread support
-           CM.unless CC.rtsSupportsBoundThreads
-                     (error errMes)             >>
-
-           -- initial setup/checks
-           CA.hideCursor >>
-
-           -- text encoding
-           SI.mkTextEncoding "UTF-8//TRANSLIT" >>= \te ->
-           SI.hSetEncoding SI.stdout te        >>
-
-           clearScreen
-    where
-          errMes = unlines
-            ["\nError: you *must* compile this program with -threaded!",
-             "Just add",
-             "",
-             "    ghc-options:      -threaded",
-             "",
-             "in your .cabal file (executable section) and you will be fine!"]
-
--- clears screen
-clearScreen :: IO ()
-clearScreen = CA.setCursorPosition 0 0 >>
-              CA.setSGR [CA.Reset]     >>
-              displaySizeErr           >>= \(w, h) ->
-              CM.replicateM_ (fromIntegral $ w*h) (putChar ' ')
-
-cleanAndExit :: IO ()
-cleanAndExit = CA.setSGR [CA.Reset]     >>
-               CA.clearScreen           >>
-               CA.setCursorPosition 0 0 >>
-               CA.showCursor
-
--- plane
-blitMap :: Plane -> Plane -> IO ()
-blitMap po pn =
-            CM.when (planeSize po /= planeSize pn)
-                    (error "blitMap: different plane sizes")      >>
-            CA.setCursorPosition 0 0                              >>
-                -- setCursorPosition is *zero* based!
-            blitToTerminal (0, 0) (orderedCells po) (orderedCells pn)
-
-orderedCells :: Plane -> [[Cell]]
-orderedCells p = LS.chunksOf (fromIntegral w) cells
-    where
-          cells  = map snd $ assocsPlane p
-          (w, _) = planeSize p
-
-
--- ordered sequence of cells, both old and new, like they were a String to
--- print to screen.
--- Coords: initial blitting position
--- Remember that this Column is *zero* based
-blitToTerminal :: Coords -> [[Cell]] -> [[Cell]] -> IO ()
-blitToTerminal (rr, rc) ocs ncs = CM.foldM_ blitLine rr oldNew
-    where
-          oldNew :: [[(Cell, Cell)]]
-          oldNew = zipWith zip ocs ncs
-
-          -- row = previous row
-          blitLine :: Row -> [(Cell, Cell)] -> IO Row
-          blitLine pr ccs =
-                CM.foldM_ blitCell 0 ccs               >>
-                -- have to use setCursorPosition (instead of nextrow) b/c
-                -- on win there is an auto "go-to-next-line" when reaching
-                -- column end and on win it does not do so
-                let wr = pr + 1 in
-                CA.setCursorPosition (fromIntegral wr)
-                                     (fromIntegral rc) >>
-                return wr
-
-          -- k is "spaces to skip"
-          blitCell :: Int -> (Cell, Cell) -> IO Int
-          blitCell k (clo, cln)
-                | cln == clo = return (k+1)
-                | otherwise  = moveIf k         >>= \k' ->
-                               putCellStyle cln >>
-                               return k'
-
-          moveIf :: Int -> IO Int
-          moveIf k | k == 0    = return k
-                   | otherwise = CA.cursorForward k >>
-                                 return 0
-
-putCellStyle :: Cell -> IO ()
-putCellStyle c = CA.setSGR ([CA.Reset] ++ sgrb ++ sgrr ++ sgrc) >>
-                 putChar (cellChar c)
-    where
-          sgrb | isBold c  = [CA.SetConsoleIntensity CA.BoldIntensity]
-               | otherwise = []
-
-          sgrr | isReversed c = [CA.SetSwapForegroundBackground True]
-               | otherwise    = []
-
-          sgrc | Just (k, i) <- cellColor c = [CA.SetColor CA.Foreground i k]
-               | otherwise                  = []
-
-oneTickSec :: Integer
-oneTickSec = 10 ^ (6 :: Integer)

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Interface.hs

@@ -1,90 +0,0 @@
--------------------------------------------------------------------------------
--- Layer 2 (mockable IO), as per
--- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html
--- 2019 Francesco Ariis GPLv3
--------------------------------------------------------------------------------
-
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE LambdaCase #-}
-
-module Terminal.Game.Layer.Object.Interface where
-
-import Terminal.Game.Plane
-import Terminal.Game.Layer.Object.Primitive
-
-import qualified Control.Concurrent as CC
-import qualified Control.Monad.Catch as MC
-
--------------------------------------------------------------------------------
--- mtl interface for game
-
-type MonadGameIO m = (MonadInput m, MonadTimer m,
-                      MonadException m, MonadLogic m,
-                      MonadDisplay m)
-
-data InputHandle = InputHandle
-            { ihKeyMVar     :: CC.MVar [Event],
-              ihOpenThreads :: [CC.ThreadId] }
-
-class Monad m => MonadInput m where
-    startEvents :: TPS -> m InputHandle
-    pollEvents  :: CC.MVar [Event] -> m [Event]
-    stopEvents :: [CC.ThreadId] -> m ()
-
-class Monad m => MonadTimer m where
-    getTime :: m Integer     -- to nanoseconds
-    sleepABit :: TPS -> m () -- Given TPS, sleep a fracion of a single
-                             -- Tick.
-
--- if a fails, do b (useful for cleaning up)
-class Monad m => MonadException m where
-    cleanUpErr :: m a -> m b -> m a
-    onException :: m a -> m b -> m a
-    throwExc :: ATGException -> m a
-
-class Monad m => MonadLogic m where
-    -- decide whether it's time to quit
-    checkQuit :: (s -> Bool) -> s -> m Bool
-
-class Monad m => MonadDisplay m where
-    setupDisplay :: m ()
-    clearDisplay :: m ()
-    displaySize :: m (Maybe Dimensions)
-    blitPlane :: Maybe Plane -> Plane -> m ()
-    shutdownDisplay :: m ()
-
-displaySizeErr :: (MonadDisplay m, MonadException m) => m Dimensions
-displaySizeErr = displaySize >>= \case
-                   Nothing -> throwExc CannotGetDisplaySize
-                   Just d -> return d
-
--------------------------------------------------------------------------------
--- Error handling
-
--- | @ATGException@s are thrown synchronously for easier catching.
-data ATGException = CannotGetDisplaySize
-                  | DisplayTooSmall Dimensions Dimensions
-                        -- ^ Required and actual dimensions.
-
-instance Show ATGException where
-    show CannotGetDisplaySize = "CannotGetDisplaySize"
-    show (DisplayTooSmall (sw, sh) tds) =
-      let colS ww = ww < sw
-          rowS wh = wh < sh
-
-          smallMsg :: Dimensions -> String
-          smallMsg (ww, wh) =
-                let cm = show ww ++ " columns"
-                    rm = show wh ++ " rows"
-                    em | colS ww && rowS wh = cm ++ " and " ++ rm
-                       | colS ww = cm
-                       | rowS wh = rm
-                       | otherwise = "smallMsg: passed correct term size!"
-                in
-                  "This games requires a display of " ++ show sw ++
-                  " columns and " ++ show sh ++ " rows.\n" ++
-                  "Yours only has " ++ em ++ "!\n\n" ++
-                  "Please resize your terminal and restart the game.\n"
-      in "DisplayTooSmall.\n" ++ smallMsg tds
-
-instance MC.Exception ATGException where

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Narrate.hs

@@ -1,30 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module Terminal.Game.Layer.Object.Narrate where
-
--- Narrate Monad, replay on screen from a GRec
-
-import Terminal.Game.Layer.Object.Interface
-import Terminal.Game.Layer.Object.Primitive
-import Terminal.Game.Layer.Object.IO () -- MonadIo
-
-import qualified Control.Monad.Catch as MC
-import qualified Control.Monad.State as S
-import qualified Control.Monad.Trans as T
-
-
-newtype Narrate a = Narrate (S.StateT GRec IO a)
-                deriving (Functor, Applicative, Monad,
-                          T.MonadIO, S.MonadState GRec,
-                          MC.MonadThrow, MC.MonadCatch, MC.MonadMask)
-
-instance MonadInput Narrate where
-    startEvents fps = T.liftIO $ startEvents fps
-    pollEvents _ = S.state getPolled
-    stopEvents ts = T.liftIO $ stopEvents ts
-
-instance MonadLogic Narrate where
-    checkQuit _ _ = S.gets isOver
-
-runReplay :: Narrate a -> GRec -> IO a
-runReplay (Narrate s) k = S.evalStateT s k

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Primitive.hs

@@ -1,93 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE LambdaCase #-}
-
-module Terminal.Game.Layer.Object.Primitive where
-
-import Terminal.Game.Plane
-
-import qualified GHC.Generics as G
-import qualified Data.ByteString as BS
-import qualified Data.Serialize as Z
-import qualified Data.Sequence as S
-import qualified Test.QuickCheck as Q
-
--------------------------------------------------------------------------------
--- Assorted API types
-
--- | The number of 'Tick's fed each second to the logic function;
--- constant on every machine. /Frames/ per second might be lower
--- (depending on drawing function onerousness, terminal refresh rate,
--- etc.).
-type TPS = Integer
-
--- | The number of frames blit to terminal per second. Frames might be
--- dropped, but game speed will remain constant. Check @balls@
--- (@cabal run -f examples balls@) to see how to display FPS.
--- For obvious reasons (blits would be wasted) @max FPS = TPS@.
-type FPS = Integer
-
--- | An @Event@ is a 'Tick' (time passes) or a 'KeyPress'.
-data Event = Tick
-           | KeyPress Char
-           deriving (Show, Eq, G.Generic)
-instance Z.Serialize Event where
-
-instance Q.Arbitrary Event where
-  arbitrary = Q.oneof [ pure Tick,
-                        KeyPress <$> Q.arbitrary ]
-
--- | Game environment with current terminal dimensions and current display
--- rate.
-data GEnv = GEnv { eTermDims :: Dimensions,
-                        -- ^ Current terminal dimensions.
-                   eFPS :: FPS
-                        -- ^ Current blitting rate.
-                       }
-    deriving (Show, Eq)
-
--------------------------------------------------------------------------------
--- GRec record/replay game typs
-
--- | Opaque data type with recorded game input, for testing purposes.
-data GRec = GRec { aPolled :: S.Seq [Event],
-                                -- Seq. of polled events
-                   aTermSize :: S.Seq (Maybe Dimensions) }
-                                -- Seq. of polled termdims
-        deriving (Show, Eq, G.Generic)
-instance Z.Serialize GRec where
-
-igrec :: GRec
-igrec = GRec S.Empty S.Empty
-
-addDims :: Maybe Dimensions -> GRec -> GRec
-addDims mds (GRec p s) = GRec p (mds S.<| s)
-
-getDims :: GRec -> (Maybe Dimensions, GRec)
-getDims (GRec p (ds S.:|> d)) = (d, GRec p ds)
-getDims _ = error "getDims: empty Seq"
-    -- Have to use _ or “non exhaustive patterns” warning
-
-addPolled :: [Event] -> GRec -> GRec
-addPolled es (GRec p s) = GRec (es S.<| p) s
-
-getPolled :: GRec -> ([Event], GRec)
-getPolled (GRec (ps S.:|> p) d) = (p, GRec ps d)
-getPolled _ = error "getEvents: empty Seq"
-
-isOver :: GRec -> Bool
-isOver (GRec S.Empty _) = True
-isOver _ = False
-
--- | Reads a file containing a recorded session.
-readRecord :: FilePath -> IO GRec
-readRecord fp = Z.decode <$> BS.readFile fp >>= \case
-                  Left e  -> error $ "readRecord could not decode: " ++
-                                     show e
-                  Right r -> return r
-
--- | Convenience function to create a 'GRec' from screen size (constant) plus a list of events. Useful with 'setupGame'.
-createGRec :: Dimensions -> [Event] -> GRec
-createGRec ds es = let l = length es * 2 in
-                   GRec (S.fromList [es])
-                        (S.fromList . replicate l $ Just ds)
-

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Record.hs

@@ -1,53 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module Terminal.Game.Layer.Object.Record where
-
--- Record Monad, for when I need to play the game and record Events
--- (keypresses, ticks, screen size, FPS) to a file.
-
-import Terminal.Game.Layer.Object.Interface
-import Terminal.Game.Layer.Object.Primitive
-import Terminal.Game.Layer.Object.IO ()
-
-import qualified Control.Concurrent   as CC
-import qualified Control.Monad.Catch  as MC
-import qualified Control.Monad.Reader as R
-import qualified Control.Monad.Trans  as T -- MonadIO
-import qualified Data.ByteString      as BS
-import qualified Data.Serialize       as S
-
--- record the key pressed in a game session
-
-newtype Record a = Record (R.ReaderT (CC.MVar GRec) IO a)
-                deriving (Functor, Applicative, Monad,
-                          T.MonadIO, R.MonadReader (CC.MVar GRec),
-                          MC.MonadThrow, MC.MonadCatch, MC.MonadMask)
-
--- Lifts IO interface, records where necessary
-instance MonadInput Record where
-    startEvents tps = T.liftIO (startEvents tps)
-    pollEvents ve = T.liftIO (pollEvents ve) >>= \es ->
-                    modMRec addPolled es
-    stopEvents ts = T.liftIO (stopEvents ts)
-
-instance MonadDisplay Record where
-    setupDisplay = T.liftIO setupDisplay
-    clearDisplay = T.liftIO clearDisplay
-    displaySize = T.liftIO displaySize >>= \ds ->
-                  modMRec addDims ds
-    blitPlane mp p = T.liftIO (blitPlane mp p)
-    shutdownDisplay = T.liftIO shutdownDisplay
-
--- logs and passes the value on
-modMRec :: (a -> GRec -> GRec) -> a -> Record a
-modMRec f a = R.ask >>= \mv ->
-              let fmv = CC.modifyMVar_ mv (return . f a) in
-              T.liftIO fmv >>
-              return a
-
-runRecord :: Record a -> CC.MVar GRec -> IO a
-runRecord (Record r) me = R.runReaderT r me
-
-writeRec :: FilePath -> CC.MVar GRec -> IO ()
-writeRec fp vr = CC.readMVar vr                >>= \k ->
-                 BS.writeFile fp (S.encode k)

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Test.hs

@@ -1,78 +0,0 @@
--------------------------------------------------------------------------------
--- Layer 2 (mockable IO), as per
--- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html
--- 2019 Francesco Ariis GPLv3
--------------------------------------------------------------------------------
-
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module Terminal.Game.Layer.Object.Test where
-
--- Test (pure) MonadGame* typeclass implementation for testing purposes.
-
-import Terminal.Game.Layer.Object.Interface
-import Terminal.Game.Layer.Object.Primitive
-
-import qualified Control.Monad.RWS as S
-
-
------------
--- TYPES --
------------
-
-data TestEvent = TCleanUpError
-               | TQuitGame
-               | TSetupDisplay
-               | TShutdownDisplay
-               | TStartGame
-               | TStartEvents
-               | TStopEvents
-        deriving (Eq, Show)
-
--- r: ()
--- w: [TestEvents]
--- s: [GTest]
-newtype Test a = Test (S.RWS () [TestEvent] GRec a)
-               deriving (Functor, Applicative, Monad,
-                         S.MonadState GRec,
-                         S.MonadWriter [TestEvent])
-
-runTest :: Test a -> GRec -> (a, [TestEvent])
-runTest (Test m) es = S.evalRWS m () es
-
-
------------
--- CLASS --
------------
-
-tconst :: a -> Test a
-tconst a = Test $ return a
-
-mockHandle :: InputHandle
-mockHandle = InputHandle (error "mock handle keyMvar")
-                         (error "mock handle threads")
-
-instance MonadInput Test where
-    startEvents _ = S.tell [TStartEvents] >>
-                    return mockHandle
-    pollEvents _ = S.state getPolled
-    stopEvents _ = S.tell [TStopEvents]
-
-instance MonadTimer Test where
-    getTime = return 1
-    sleepABit _ = return ()
-
-instance MonadException Test where
-    cleanUpErr a _ = S.tell [TCleanUpError] >> a
-    onException a _ = S.tell [TCleanUpError] >> a
-    throwExc e = error . show $ e
-
-instance MonadLogic Test where
-    checkQuit _ _ = S.gets isOver
-
-instance MonadDisplay Test where
-    setupDisplay = () <$ S.tell [TSetupDisplay]
-    clearDisplay = return ()
-    displaySize = Test $ S.state getDims
-    blitPlane _ _ = return ()
-    shutdownDisplay = () <$ S.tell [TShutdownDisplay]

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Plane.hs

@@ -1,237 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
--------------------------------------------------------------------------------
--- Screen datatypes and functions
--- 2017 Francesco Ariis GPLv3
--------------------------------------------------------------------------------
-
--- a canvas where to draw our stuff
-
-module Terminal.Game.Plane where
-
-import Terminal.Game.Character
-
-import qualified Data.Array          as A
-import qualified Data.Bifunctor      as B
-import qualified Data.List.Split     as LS
-import qualified Data.Tuple          as T
-import qualified GHC.Generics        as G
-import qualified System.Console.ANSI as CA
-
-
-----------------
--- DATA TYPES --
-----------------
-
--- | 'Row's and 'Column's are 1-based (top-left position is @1 1@).
-type Coords = (Row, Column)
-type Row    = Int
-type Column = Int
-
--- | Size of a surface in 'Row's and 'Column's.
-type Dimensions = (Width, Height)
-
--- | Expressed in 'Column's.
-type Width  = Int
--- | Expressed in 'Row's.
-type Height = Int
-
-type Bold     = Bool
-type Reversed = Bool
-
--- can be an ASCIIChar or a special, transparent character
-data Cell = CellChar Char Bold
-                     Reversed (Maybe (CA.Color, CA.ColorIntensity))
-          | Transparent
-          deriving (Show, Eq, Ord, G.Generic)
-        -- I found no meaningful speed improvements by making this
-        -- only w/ 1 constructor.
-
--- | A two-dimensional surface (Row, Column) where to blit stuff.
-newtype Plane = Plane { fromPlane :: A.Array Coords Cell }
-              deriving (Show, Eq, G.Generic)
-        -- Could this be made into an UArray? Nope, since UArray is
-        -- only instanced on Words, Int, Chars, etc.
-
--------------------------------------------------------------------------------
--- Plane interface (abstracting Array)
-
-listPlane :: Coords -> [Cell] -> Plane
-listPlane (r, c) cs = Plane $ A.listArray ((1,1), (r, c)) cs
-
--- | Dimensions or a plane.
-planeSize :: Plane -> Dimensions
-planeSize p = T.swap . snd $ A.bounds (fromPlane p)
-
-assocsPlane :: Plane -> [(Coords, Cell)]
-assocsPlane p = A.assocs (fromPlane p)
-
-elemsPlane :: Plane -> [Cell]
-elemsPlane p = A.elems (fromPlane p)
-
--- Array.//
-updatePlane :: Plane -> [(Coords, Cell)] -> Plane
-updatePlane (Plane a) kcs = Plane $ a A.// kcs
-
--- faux map
-mapPlane :: (Cell -> Cell) -> Plane -> Plane
-mapPlane f (Plane a) = Plane $ fmap f a
-
-
-----------
--- CREA --
-----------
-
-creaCell :: Char -> Cell
-creaCell ch = CellChar chm False False Nothing
-    where
-          chm = win32SafeChar ch
-
-colorCell :: CA.Color -> CA.ColorIntensity -> Cell -> Cell
-colorCell k i (CellChar c b r _) = CellChar c b r (Just (k, i))
-colorCell _ _ Transparent        = Transparent
-
-boldCell :: Cell -> Cell
-boldCell (CellChar c _ r k) = CellChar c True r k
-boldCell Transparent        = Transparent
-
-reverseCell :: Cell -> Cell
-reverseCell (CellChar c b _ k) = CellChar c b True k
-reverseCell Transparent        = Transparent
-
--- | Creates 'Plane' from 'String', good way to import ASCII
--- art/diagrams. @error@s on empty string.
-stringPlane :: String -> Plane
-stringPlane t = stringPlaneGeneric Nothing t
-
--- | Same as 'stringPlane', but with transparent 'Char'.
--- @error@s on empty string.
-stringPlaneTrans :: Char -> String -> Plane
-stringPlaneTrans c t = stringPlaneGeneric (Just c) t
-
--- | Creates an empty, opaque 'Plane'.
-blankPlane :: Width -> Height -> Plane
-blankPlane w h = listPlane (h, w) (repeat $ creaCell ' ')
-
--- | Adds transparency to a plane, matching a given character
-makeTransparent :: Char -> Plane -> Plane
-makeTransparent tc p = mapPlane f p
-    where
-          f cl | cellChar cl == tc = Transparent
-               | otherwise         = cl
-
--- | Changes every transparent cell in the 'Plane' to an opaque @' '@
--- character.
-makeOpaque :: Plane -> Plane
-makeOpaque p = let (w, h) = planeSize p
-               in pastePlane p (blankPlane w h) (1, 1)
-
-
-
------------
--- SLICE --
------------
-
--- | Paste one plane over the other at a certain position (p1 gets over p2).
-pastePlane :: Plane -> Plane -> Coords -> Plane
-pastePlane p1 p2 (r, c)
-            | r > h2 || c > w2 = p2
-            | otherwise =
-                let ks = assocsPlane p1
-                    fs = filter (\x -> solid x && inside x) ks
-                    ts = fmap (B.first trasl) fs
-                in updatePlane p2 ts
-    where
-          trasl :: Coords -> Coords
-          trasl (wr, wc) = (wr + r - 1, wc + c - 1)
-
-          -- inside new position, cheaper than first mapping and then
-          -- filtering.
-          inside (wcs, _) =
-                let (r1', c1') = trasl wcs
-                in r1' >= 1 && r1' <= h2 &&
-                   c1' >= 1 && c1' <= w2
-
-          solid (_, Transparent) = False
-          solid _                = True
-
-          (w2, h2)  = planeSize p2
-
--- | Cut out a plane by top-left and bottom-right coordinates.
-subPlane :: Plane -> Coords -> Coords -> Plane
-subPlane p (r1, c1) (r2, c2)
-        | r1 > r2 || c1 > c2 = err (r1, c1) (r2, c2)
-        | otherwise          =
-            let cs       = assocsPlane p
-                fs       = filter f cs
-                (pw, ph) = planeSize p
-                (w, h)   = (min pw (c2-c1+1), min ph (r2-r1+1))
-            in listPlane (h, w) (map snd fs)
-    where
-          f ((rw, cw), _) = rw >= r1 && rw <= r2 &&
-                            cw >= c1 && cw <= c2
-
-          err p1 p2 = error ("subPlane: top-left point " ++ show p1 ++
-                             " > bottom-right point " ++ show p2 ++ ".")
-
--------------
--- INQUIRE --
--------------
-
-cellChar :: Cell -> Char
-cellChar (CellChar c _ _ _) = c
-cellChar Transparent        = ' '
-
-cellColor :: Cell -> Maybe (CA.Color, CA.ColorIntensity)
-cellColor (CellChar _ _ _ k) = k
-cellColor Transparent        = Nothing
-
-isBold :: Cell -> Bool
-isBold (CellChar _ b _ _) = b
-isBold _                  = False
-
-isReversed :: Cell -> Bool
-isReversed (CellChar _ _ r _) = r
-isReversed _                  = False
-
--- | A String (@\n@ divided and ended) representing the 'Plane'. Useful
--- for debugging/testing purposes.
-planePaper :: Plane -> String
-planePaper p = unlines . LS.chunksOf w . map cellChar $ elemsPlane p
-    where
-          w :: Int
-          w = fromIntegral . fst . planeSize $ p
-
------------------
--- ANCILLARIES --
------------------
-
-stringPlaneGeneric :: Maybe Char -> String -> Plane
-stringPlaneGeneric _ "" = makeTransparent ' ' (blankPlane 1 1)
-stringPlaneGeneric mc t = vitrous
-    where
-          lined = lines t
-
-          h :: Int
-          h = length lined
-
-          w :: Int
-          w = maximum (map length lined)
-
-          pad :: Int -> String -> String
-          pad mw tl = take mw (tl ++ repeat ' ')
-
-          padded :: [String]
-          padded = map (pad w) lined
-
-          celled :: [Cell]
-          celled = map creaCell . concat $ padded
-
-          plane :: Plane
-          plane = listPlane (h, w) celled
-
-          vitrous :: Plane
-          vitrous = case mc of
-                      Just c  -> makeTransparent c plane
-                      Nothing -> plane
-

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Random.hs

@@ -1,20 +0,0 @@
-module Terminal.Game.Random ( R.StdGen,
-                              R.UniformRange,
-                              R.getStdGen,
-                              R.mkStdGen,
-                              getRandom,
-                              pickRandom )
-            where
-
-import System.Random as R
-
-
--- | Simple, pure pseudo-random generator.
-getRandom :: UniformRange a => (a, a) -> StdGen -> (a, StdGen)
-getRandom bs sg = uniformR bs sg
-
--- | Picks at random from list.
-pickRandom :: [a] -> StdGen -> (a, StdGen)
-pickRandom as sg = let l = length as
-                       (a, sg') = getRandom (0, l-1) sg
-                   in (as !! a, sg')

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Timer.hs

@@ -1,3 +0,0 @@
-module Terminal.Game.Timer (module T) where
-
-import Control.Timer.Tick as T

vendored/ansi-terminal-game-1.8.0.0/test/Terminal/Game/DrawSpec.hs

@@ -1,68 +0,0 @@
-module Terminal.Game.DrawSpec where
-
-import Test.Hspec
-import Terminal.Game.Plane
-import Terminal.Game.Draw
-import Terminal.Game -- language hyphenators
-
-
-spec :: Spec
-spec = do
-
-  describe "mergePlanes" $ do
-    it "piles multiple planes together" $
-      mergePlanes (stringPlane "aa")
-                  [((1,2), cell 'b')] `shouldBe` stringPlane "ab"
-    it "works in the middle too" $
-      mergePlanes (stringPlane "aaa\naaa\naaa")
-                  [((2,2), cell 'b')] `shouldBe`
-                    stringPlane "aaa\naba\naaa"
-
-  describe "textBox/textBoxLiquid" $ do
-    let s  = "las rana in Spa"
-        w  = 6
-        ps = textBox w 2 s
-        pl = textBoxLiquid w s
-    it "textBox follows specific size" $
-      planeSize ps `shouldBe` (6, 2)
-    it "textBoxLiquid fits the whole string" $
-      planeSize pl `shouldBe` (6, 3)
-    it "textBox should make a transparent plane" $
-      let p1 = textBox 6 1 "a c e "
-          p2 = textBox 6 1 " b d f"
-          pc = p1 & (1, 1) % p2
-      in planePaper pc `shouldBe` "abcdef\n"
-
-  describe "textBoxHypen" $ do
-    let tbh = textBoxHyphen spanish 8 2 "Con pianito"
-    it "hyphens long words" $
-      planePaper tbh `shouldSatisfy` elem '-'
-
-  describe "***" $ do
-    let a  = stringPlane ".\n.\n.\n"
-        b  = stringPlane "*"
-        c  = stringPlane ".\n*\n.\n"
-    it "blits b in the centre of a" $
-      a *** b `shouldBe` c
-
-  -- combinators
-
-  let sp = stringPlane "ab"
-      bp = blankPlane 4 3
-
-  describe "%^>" $ do
-    it "blits in the top right corner" $
-      planePaper (bp & (1,1) %^> sp) `shouldBe` "  ab\n    \n    \n"
-
-  describe "%_<" $ do
-    it "blits in the bottom left corner" $
-      planePaper (bp & (2,1) %.< sp) `shouldBe` "    \nab  \n    \n"
-
-  describe "%_<" $ do
-    it "blits in the bottom left corner" $
-      planePaper (bp & (2,3) %.> sp) `shouldBe` "    \nab  \n    \n"
-
-  describe "%" $ do
-    it "mixes with alternative combinators" $
-      planePaper (bp & (1,2) % sp & (2,3) %.> sp) `shouldBe`
-        " ab \nab  \n    \n"

vendored/ansi-terminal-game-1.8.0.0/test/Terminal/Game/Layer/ImperativeSpec.hs

@@ -1,54 +0,0 @@
-module Terminal.Game.Layer.ImperativeSpec where
-
-import Terminal.Game.Layer.Imperative
-import Terminal.Game.Layer.Object
-import Terminal.Game.Random
-import Alone
-import Balls
-
-import Test.Hspec
-import Test.Hspec.QuickCheck
-
-import qualified Test.QuickCheck as Q
-
-spec :: Spec
-spec = do
-
-  describe "runGame" $ do
-    let nd = error "<not-defined>"
-        s :: (Integer, Bool, Integer)
-        s = (0, False, 0)
-        lf (t, True, i) Tick         = (t+1, True, i+1)
-        lf (t, b,    i) Tick         = (t+1, b,    i  )
-        lf (t, _,    i) (KeyPress _) = (t,   True, i  )
-        qf (3, _,    _) = True
-        qf _            = False
-        es = [Tick, KeyPress 'c', KeyPress 'c', Tick, Tick]
-        g = Game nd s (const lf) nd qf
-    it "does not confuse input and logic" $
-      testGame g (createGRec (80, 24) es) `shouldBe` (3, True, 2)
-
-  describe "testGame" $ do
-    it "tests a game" $ do
-        r <- readRecord "test/records/alone-record-test.gr"
-        testGame aloneInARoom r `shouldBe` MyState (20, 66) Stop True
-    it "picks up screen resize events" $ do
-        r <- readRecord "test/records/balls-dims.gr"
-        let g = fireworks (mkStdGen 1)
-            t = testGame g r
-        length (balls t) `shouldBe` 1
-    it "picks up screen resize events" $ do
-        r <- readRecord "test/records/balls-slow.gr"
-        let g = fireworks (mkStdGen 1)
-            t = testGame g r
-        bslow t `shouldBe` True
-    it "does not hang on empty/unclosed input" $
-        let w = createGRec (80, 24) [Tick] in
-        testGame aloneInARoom w `shouldBe` MyState (10, 10) Stop False
-    modifyMaxSize (const 1000) $
-      it "does not crash/hang on random input" $ Q.property $
-        let genEvs = Q.listOf1 Q.arbitrary
-        in Q.forAll genEvs $
-             \es -> let w = createGRec (80, 24) es
-                        a = testGame aloneInARoom w
-                    in a == a

vendored/ansi-terminal-game-1.8.0.0/test/Terminal/Game/PlaneSpec.hs

@@ -1,59 +0,0 @@
-module Terminal.Game.PlaneSpec where
-
-import Test.Hspec
-import Terminal.Game.Plane
-import Terminal.Game.Draw
-
-import qualified Control.Exception as E
-
-
-spec :: Spec
-spec = do
-
-  let testPlane =         blankPlane 2 2 &
-                  (1,1) % box 2 2 '.'    &
-                  (1,2) % cell ' '
-
-  describe "listPlane" $ do
-    it "creates a plane from string" $
-      listPlane (2,2) (map creaCell ". ..") `shouldBe` testPlane
-    it "ignores extra characters" $
-      listPlane (2,2) (map creaCell ". ..abc") `shouldBe` testPlane
-
-  describe "pastePlane" $ do
-    it "pastes a simple plane onto another" $
-      pastePlane (cell 'a') (cell 'b') (1,1) `shouldBe` cell 'a'
-
-  describe "stringPlane" $ do
-    it "creates plane from spec" $
-      stringPlane ".\n.." `shouldBe` testPlane
-
-  describe "stringPlaneTrans" $ do
-    it "allows transparency" $
-      stringPlaneTrans '.' ".\n.." `shouldBe` makeTransparent '.' testPlane
-
-  describe "updatePlane" $ do
-    let ma = listPlane (2,1) (map creaCell "ab")
-        mb = listPlane (2,1) (map creaCell "xb")
-    it "updates a Plane" $
-      updatePlane ma [((1,1), creaCell 'x')] `shouldBe` mb
-
-  describe "subPlane" $ do
-    let pa = word "prova" === word "fol"
-    it "cuts out a plane" $
-      planePaper (subPlane pa (1, 1) (2, 1)) `shouldBe` "p\nf\n"
-    it "does not crash on OOB" $
-      planeSize (subPlane pa (1, 1) (10, 10)) `shouldBe` (5, 2)
-    it "errs on emptycell" $
-      E.evaluate (subPlane pa (2, 3) (1, 1)) `shouldThrow`
-        errorCall "subPlane: top-left point (2,3) > bottom-right point (1,1)."
-    it "but not on a single cell" $
-      subPlane pa (2, 3) (2, 3) `shouldBe` cell 'l'
-
-  describe "hcat/vcat" $ do
-    let pa = blankPlane 2 1
-        pb = blankPlane 3 4
-    it "concats planes horizontally with hcat" $
-      planeSize (hcat [pa, pb]) `shouldBe` (5, 4)
-    it "concats planes horizontally with vcat" $
-      planeSize (vcat [pa, pb]) `shouldBe` (3, 5)

vendored/ansi-terminal-game-1.8.0.0/test/Terminal/Game/RandomSpec.hs

@@ -1,20 +0,0 @@
-module Terminal.Game.RandomSpec where
-
-import Test.Hspec
-import Test.Hspec.QuickCheck
-import Terminal.Game.Random
-
-
-spec :: Spec
-spec = do
-
-  describe "pickRandom" $ do
-    prop "picks items at random from a list" $
-      \i -> let g = mkStdGen i
-            in fst (pickRandom ['a', 'b'] g) /= 'c'
-    prop "does not exclude any item" $
-      \i -> let g = mkStdGen i
-                rf tg = pickRandom [1,2] tg
-                rs = iterate (\(_, lg') -> rf lg')  (rf g)
-                ts = take 100 rs
-            in sum (map fst ts) /= length ts

vendored/ansi-terminal-game-1.8.0.0/test/Test.hs

@@ -1 +0,0 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}