diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 1204e5f..03921f6 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -17,7 +17,6 @@ import GHCup.OptParse.Common import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.File import GHCup.Utils.Logger import GHCup.Utils.String.QQ diff --git a/ghcup.cabal b/ghcup.cabal index 611b112..85501f9 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -65,6 +65,7 @@ library GHCup.Requirements GHCup.Types GHCup.Types.JSON + GHCup.Types.JSON.Utils GHCup.Types.Optics GHCup.Utils GHCup.Utils.Dirs diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 5014196..5633f78 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DuplicateRecordFields #-} {-| @@ -30,12 +31,15 @@ import Data.Map.Strict ( Map ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Text ( Text ) import Data.Versions -import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text) +import GHC.IO.Exception ( ExitCode ) +import Optics ( makeLenses ) +import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text, (<+>)) import URI.ByteString #if defined(BRICK) import Graphics.Vty ( Key(..) ) #endif +import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified GHC.Generics as GHC @@ -600,3 +604,27 @@ data LoggerConfig = LoggerConfig instance NFData LoggerConfig where rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors) + +data ProcessError = NonZeroExit Int FilePath [String] + | PTerminated FilePath [String] + | PStopped FilePath [String] + | NoSuchPid FilePath [String] + deriving Show + +instance Pretty ProcessError where + pPrint (NonZeroExit e exe args) = + text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".") + pPrint (PTerminated exe args) = + text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated." + pPrint (PStopped exe args) = + text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped." + pPrint (NoSuchPid exe args) = + text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "." +data CapturedProcess = CapturedProcess + { _exitCode :: ExitCode + , _stdOut :: BL.ByteString + , _stdErr :: BL.ByteString + } + deriving (Eq, Show) + +makeLenses ''CapturedProcess diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index dded840..8aafad9 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -22,10 +22,8 @@ Portability : portable module GHCup.Types.JSON where import GHCup.Types +import GHCup.Types.JSON.Utils import GHCup.Utils.MegaParsec -import GHCup.Utils.Prelude -import GHCup.Utils.Logger () -- TH is broken shite and needs GHCup.Utils.Logger for linking, although we don't depend on the file. - -- This is due to the boot file. import Control.Applicative ( (<|>) ) import Data.Aeson hiding (Key) @@ -40,6 +38,7 @@ import Text.Casing import qualified Data.List.NonEmpty as NE import qualified Data.Text as T +import qualified Data.Text.Encoding.Error as E import qualified Text.Megaparsec as MP import qualified Text.Megaparsec.Char as MPC @@ -78,7 +77,7 @@ instance FromJSON Tag where x -> pure (UnknownTag x) instance ToJSON URI where - toJSON = toJSON . decUTF8Safe . serializeURIRef' + toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef' instance FromJSON URI where parseJSON = withText "URL" $ \t -> diff --git a/lib/GHCup/Types/JSON/Utils.hs b/lib/GHCup/Types/JSON/Utils.hs new file mode 100644 index 0000000..33fa2cd --- /dev/null +++ b/lib/GHCup/Types/JSON/Utils.hs @@ -0,0 +1,17 @@ +{-| +Module : GHCup.Types.JSON.Utils +Description : Utils for TH splices +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} + +module GHCup.Types.JSON.Utils where + +import qualified Data.Text as T + +removeLensFieldLabel :: String -> String +removeLensFieldLabel str' = + maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str' diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index a05dbfb..a06f51a 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs index f777c61..a3ff8a2 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Utils/File/Common.hs @@ -1,11 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -module GHCup.Utils.File.Common where +module GHCup.Utils.File.Common ( + module GHCup.Utils.File.Common + , ProcessError(..) + , CapturedProcess(..) + ) where import GHCup.Utils.Prelude +import GHCup.Types(ProcessError(..), CapturedProcess(..)) import Control.Monad.Reader import Data.Maybe @@ -24,33 +28,6 @@ import qualified Text.Megaparsec as MP -data ProcessError = NonZeroExit Int FilePath [String] - | PTerminated FilePath [String] - | PStopped FilePath [String] - | NoSuchPid FilePath [String] - deriving Show - -instance Pretty ProcessError where - pPrint (NonZeroExit e exe args) = - text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".") - pPrint (PTerminated exe args) = - text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated." - pPrint (PStopped exe args) = - text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped." - pPrint (NoSuchPid exe args) = - text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "." - -data CapturedProcess = CapturedProcess - { _exitCode :: ExitCode - , _stdOut :: BL.ByteString - , _stdErr :: BL.ByteString - } - deriving (Eq, Show) - -makeLenses ''CapturedProcess - - - -- | Search for a file in the search paths. -- -- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`. diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 980485a..a30c697 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} @@ -18,7 +17,7 @@ module GHCup.Utils.Logger where import GHCup.Types import GHCup.Types.Optics -import {-# SOURCE #-} GHCup.Utils.File.Common +import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles) import GHCup.Utils.String.QQ import Control.Exception.Safe diff --git a/lib/GHCup/Utils/Logger.hs-boot b/lib/GHCup/Utils/Logger.hs-boot index 0995e40..9e3b1b9 100644 --- a/lib/GHCup/Utils/Logger.hs-boot +++ b/lib/GHCup/Utils/Logger.hs-boot @@ -1,7 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} module GHCup.Utils.Logger where diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index 99fbb06..473652b 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -30,7 +30,7 @@ where import GHCup.Types import GHCup.Errors import GHCup.Types.Optics -import {-# SOURCE #-} GHCup.Utils.Logger +import {-# SOURCE #-} GHCup.Utils.Logger (logWarn) #if defined(IS_WINDOWS) import GHCup.Utils.Prelude.Windows #else @@ -308,11 +308,6 @@ intToText :: Integral a => a -> T.Text intToText = TL.toStrict . B.toLazyText . B.decimal -removeLensFieldLabel :: String -> String -removeLensFieldLabel str' = - maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str' - - pvpToVersion :: MonadThrow m => PVP -> Text -> m Version pvpToVersion pvp_ rest = either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_