{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Types used by @Stack.Storage@ modules.

module Stack.Types.Storage
  ( StoragePrettyException (..)
  , ProjectStorage (..)
  , UserStorage (..)
  ) where

import           Pantry.SQLite ( Storage )
import           Stack.Prelude

-- | Type representing \'pretty\' exceptions thrown by functions exported by

-- modules beginning @Stack.Storage@.

data StoragePrettyException
  = StorageMigrationFailure !Text !(Path Abs File) !SomeException
  deriving (Int -> StoragePrettyException -> ShowS
[StoragePrettyException] -> ShowS
StoragePrettyException -> String
(Int -> StoragePrettyException -> ShowS)
-> (StoragePrettyException -> String)
-> ([StoragePrettyException] -> ShowS)
-> Show StoragePrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoragePrettyException -> ShowS
showsPrec :: Int -> StoragePrettyException -> ShowS
$cshow :: StoragePrettyException -> String
show :: StoragePrettyException -> String
$cshowList :: [StoragePrettyException] -> ShowS
showList :: [StoragePrettyException] -> ShowS
Show, Typeable)

instance Pretty StoragePrettyException where
  pretty :: StoragePrettyException -> StyleDoc
pretty (StorageMigrationFailure Text
desc Path Abs File
fp SomeException
ex) =
    StyleDoc
"[S-8835]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack could not migrate the the database"
         , Style -> StyleDoc -> StyleDoc
style Style
File (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
desc)
         , String -> StyleDoc
flow String
"located at"
         , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While migrating the database, Stack encountered the error:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string String
exMsg
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Please report this as an issue at"
         , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues"
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    -- See https://github.com/commercialhaskell/stack/issues/5851

    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> if String
exMsg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
winIOGHCRTSMsg
         then
           String -> StyleDoc
flow String
"This error can be caused by a bug that arises if GHC's \
                \'--io-manager=native' RTS option is set using the GHCRTS \
                \environment variable. As a workaround try setting the option \
                \in the project's Cabal file, Stack's YAML configuration file \
                \or at the command line."
         else
           String -> StyleDoc
flow String
"As a workaround you may delete the database. This \
                \will cause the database to be recreated."
   where
    exMsg :: String
exMsg = SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex
    winIOGHCRTSMsg :: String
winIOGHCRTSMsg =
      String
"\\\\.\\NUL: hDuplicateTo: illegal operation (handles are incompatible)"

instance Exception StoragePrettyException

-- | A bit of type safety to ensure we're talking to the right database.

newtype UserStorage = UserStorage
  { UserStorage -> Storage
unUserStorage :: Storage
  }

-- | A bit of type safety to ensure we're talking to the right database.

newtype ProjectStorage = ProjectStorage
  { ProjectStorage -> Storage
unProjectStorage :: Storage
  }