Ya

2020-03-01 01:05:02 +01:00 · 2020-03-01 01:05:02 +01:00 · c5699eb641
commit c5699eb641
parent e1fb60d3b1
9 changed files with 143 additions and 130 deletions
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -8,28 +8,32 @@

 module Main where

+import           GHCup
+import           GHCup.File
+import           GHCup.Logger
+import           GHCup.Prelude
+import           GHCup.Types
+
 import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Data.Bifunctor
-import qualified Data.ByteString.UTF8          as UTF8
 import           Data.Char
 import           Data.List                      ( intercalate )
 import           Data.Semigroup                 ( (<>) )
+import           Data.String.Interpolate
 import           Data.String.QQ
-import qualified Data.Text                     as T
 import           Data.Versions
-import           GHCup
-import           GHCup.Logger
-import           GHCup.File
-import           GHCup.Prelude
-import           GHCup.Types
 import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           System.Console.Pretty
 import           System.Exit
-import           URI.ByteString
+import           System.IO
 import           Text.Layout.Table
-import           Data.String.Interpolate
+import           URI.ByteString
+
+import qualified Data.ByteString               as B
+import qualified Data.ByteString.UTF8          as UTF8
+import qualified Data.Text                     as T



@ -236,12 +240,14 @@ toSettings Options {..} =

 main :: IO ()
 main = do
-  -- logger interpreter
-  let runLogger = myLoggerTStderr

  customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
    >>= \opt@Options {..} -> do
-          let settings = toSettings opt
+          let settings  = toSettings opt
+
+          -- logger interpreter
+          let runLogger = myLoggerT (LoggerConfig optVerbose $ B.hPut stderr)
+
          -- wrapper to run effects with settings
          let runInstTool =
                runLogger
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -12,72 +12,78 @@
 module GHCup where


-import qualified Codec.Archive.Tar             as Tar
-import           Control.Applicative
-import           Control.Monad
-import           Control.Monad.Fail             ( MonadFail )
-import           Control.Monad.Reader
-import           Control.Monad.Logger
-import           Control.Monad.Trans.Class      ( lift )
-import           Control.Exception.Safe
-import           Data.Aeson
-import           Data.Attoparsec.ByteString
-import           Data.ByteString                ( ByteString )
-import qualified Data.ByteString.Lazy          as L
-import           Data.ByteString.Builder
-import           Data.Foldable
-import           Data.String.QQ
-import           Data.Text                      ( Text )
-import           Data.Versions
-import           Data.IORef
 import           GHCup.Bash
 import           GHCup.File
 import           GHCup.Prelude
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
+
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Fail             ( MonadFail )
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Class      ( lift )
+import           Data.Aeson
+import           Data.Attoparsec.ByteString
+import           Data.ByteString                ( ByteString )
+import           Data.ByteString.Builder
+import           Data.Foldable
+import           Data.IORef
+import           Data.List
+import           Data.Maybe
+import           Data.String.Interpolate
+import           Data.String.QQ
+import           Data.Text                      ( Text )
+import           Data.Versions
+import           Data.Word8
+import           GHC.IO.Exception
 import           HPath
 import           HPath.IO
+import           Haskus.Utils.Variant.Excepts
+import           Network.Http.Client     hiding ( URL )
 import           Optics
 import           Prelude                 hiding ( abs
                                                , readFile
                                                )
-import           Data.List
-import           System.Info
+import           Safe
 import           System.IO.Error
+import           System.Info
+import           System.Posix.Env.ByteString    ( getEnvDefault
+                                                , getEnv
+                                                )
+import           System.Posix.FilePath          ( takeFileName )
+import           System.Posix.Files.ByteString  ( readSymbolicLink )
+import "unix"    System.Posix.IO.ByteString
+                                         hiding ( fdWrite )
+import "unix-bytestring" System.Posix.IO.ByteString
+                                                ( fdWrite )
+import           System.Posix.RawFilePath.Directory.Errors
+                                                ( hideError )
+import           System.Posix.Temp.ByteString
+import           System.Posix.Types
+import           URI.ByteString
+import           URI.ByteString.QQ
+
+import qualified Codec.Archive.Tar             as Tar
+import qualified Codec.Compression.BZip        as BZip
+import qualified Codec.Compression.GZip        as GZip
+import qualified Codec.Compression.Lzma        as Lzma
+import qualified Data.ByteString               as B
+import qualified Data.ByteString.Lazy          as L
+import qualified Data.Map.Strict               as Map
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Text.ICU                 as ICU
-import           Data.Maybe
-import qualified Data.Map.Strict               as Map
-import           Data.Word8
-import           GHC.IO.Exception
-import           Haskus.Utils.Variant.Excepts
-import           Network.Http.Client     hiding ( URL )
 import qualified System.IO.Streams             as Streams
-import           System.Posix.FilePath          ( takeFileName )
 import qualified System.Posix.FilePath         as FP
-import           System.Posix.Files.ByteString  ( readSymbolicLink )
-import           System.Posix.Env.ByteString    ( getEnvDefault )
-import           System.Posix.Temp.ByteString
 import qualified System.Posix.RawFilePath.Directory
                                               as RD
-import           System.Posix.RawFilePath.Directory.Errors
-                                                ( hideError )
-import "unix"    System.Posix.IO.ByteString
-                                         hiding ( fdWrite )
-import qualified Data.ByteString               as B
-import           System.Posix.Types
-import "unix-bytestring" System.Posix.IO.ByteString
-                                                ( fdWrite )

-import qualified Codec.Compression.GZip        as GZip
-import qualified Codec.Compression.Lzma        as Lzma
-import qualified Codec.Compression.BZip        as BZip
-import           URI.ByteString
-import           URI.ByteString.QQ
-import           Data.String.Interpolate
-import           Safe
+
+


 data Settings = Settings
@ -674,7 +680,7 @@ setGHC ver sghc = do

  -- symlink destination
  destdir <- liftIO $ ghcupBinDir
-  liftIO $ createDirIfMissing newDirPerms destdir
+  liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms destdir

  -- for ghc tools (ghc, ghci, haddock, ...)
  verfiles <- ghcToolFiles ver
@ -898,8 +904,11 @@ getDebugInfo = do

 ghcupBaseDir :: IO (Path Abs)
 ghcupBaseDir = do
-  home <- liftIO getHomeDirectory
-  pure (home </> ([rel|.ghcup|] :: Path Rel))
+  getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
+    Just r  -> parseAbs r
+    Nothing -> do
+      home <- liftIO getHomeDirectory
+      pure (home </> ([rel|.ghcup|] :: Path Rel))

 ghcupGHCBaseDir :: IO (Path Abs)
 ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
--- a/lib/GHCup/Bash.hs
+++ b/lib/GHCup/Bash.hs
@ -6,17 +6,18 @@ module GHCup.Bash
  )
 where

-import           Language.Bash.Parse
-import           Language.Bash.Word
-import           Language.Bash.Syntax
+import           Control.Monad
+import           Data.ByteString.UTF8           ( toString )
+import           Data.List
+import           Data.Maybe
 import           HPath
 import           HPath.IO
-import           Data.ByteString.UTF8           ( toString )
-import           Control.Monad
-import           Data.Maybe
-import qualified Data.ByteString.Lazy.UTF8     as UTF8
+import           Language.Bash.Parse
+import           Language.Bash.Syntax
+import           Language.Bash.Word
 import           Prelude                 hiding ( readFile )
-import           Data.List
+
+import qualified Data.ByteString.Lazy.UTF8     as UTF8


 extractAssignments :: List -> [Assign]
--- a/lib/GHCup/File.hs
+++ b/lib/GHCup/File.hs
@ -3,48 +3,48 @@

 module GHCup.File where

+import           Control.Exception.Safe
+import           Control.Monad
 import           Data.ByteString
-import qualified Data.ByteString.Lazy          as L
+import           Data.ByteString.Unsafe         ( unsafeUseAsCStringLen )
 import           Data.Char
+import           Data.Foldable
+import           Data.Functor
 import           Data.Maybe
 import           Data.String.QQ
+import           GHC.Foreign                    ( peekCStringLen )
+import           GHC.IO.Encoding                ( getLocaleEncoding )
 import           HPath
 import           HPath.IO
 import           Optics
+import           Streamly
 import           Streamly.External.ByteString
 import           Streamly.External.ByteString.Lazy
-import           Streamly
-import           System.Posix.FilePath   hiding ( (</>) )
-import           Data.Foldable
-import           Control.Monad
-import           Control.Exception.Safe
-import           Data.Functor
-import           System.Posix.Foreign           ( oExcl )
-import           System.Posix.Env.ByteString
+import           System.Exit
 import           System.IO
-import qualified System.Posix.FilePath         as FP
+import           System.Posix.Directory.ByteString
+import           System.Posix.Env.ByteString
+import           System.Posix.FD               as FD
+import           System.Posix.FilePath   hiding ( (</>) )
+import           System.Posix.Foreign           ( oExcl )
 import "unix"    System.Posix.IO.ByteString
                                         hiding ( openFd )
-import qualified System.Posix.Process.ByteString
-                                               as SPPB
-import           System.Posix.Directory.ByteString
 import           System.Posix.Process           ( ProcessStatus(..) )
 import           System.Posix.Temp.ByteString
 import           System.Posix.Types
-import qualified System.Posix.User             as PU

+
+import qualified System.Posix.Process.ByteString
+                                               as SPPB
+import qualified System.Posix.FilePath         as FP
+import qualified System.Posix.User             as PU
 import qualified Streamly.Internal.Memory.ArrayStream
                                               as AS
 import qualified Streamly.FileSystem.Handle    as FH
 import qualified Streamly.Internal.Data.Unfold as SU
 import qualified Streamly.Prelude              as S
-import           System.Exit
-import           System.Posix.FD               as FD
 import qualified Data.ByteString.UTF8          as UTF8
-import           Data.ByteString.Unsafe         ( unsafeUseAsCStringLen )
-import           GHC.IO.Encoding                ( getLocaleEncoding )
-import           GHC.Foreign                    ( peekCStringLen )
-
+import qualified Data.ByteString.Lazy          as L


 data ProcessError = NonZeroExit Int ByteString [ByteString]
--- a/lib/GHCup/Logger.hs
+++ b/lib/GHCup/Logger.hs
@ -1,30 +1,28 @@
 module GHCup.Logger where


-import           System.Console.Pretty
-import           System.IO
 import           Control.Monad.Logger
+import           System.Console.Pretty

 import qualified Data.ByteString as B


-myLoggerT :: (B.ByteString -> IO ()) -> LoggingT m a -> m a
-myLoggerT outter loggingt = runLoggingT loggingt mylogger
+data LoggerConfig = LoggerConfig {
+    lcPrintDebug :: Bool
+  , outter :: B.ByteString -> IO ()
+}
+
+
+myLoggerT :: LoggerConfig -> LoggingT m a -> m a
+myLoggerT LoggerConfig{..} loggingt = runLoggingT loggingt mylogger
 where
  mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
  mylogger _ _ level str' = do
    let l = case level of
-          LevelDebug   -> toLogStr (style Bold $ color Blue   "[ Debug ]")
+          LevelDebug   -> if lcPrintDebug then toLogStr (style Bold $ color Blue   "[ Debug ]") else mempty
          LevelInfo    -> toLogStr (style Bold $ color Green  "[ Info  ]")
          LevelWarn    -> toLogStr (style Bold $ color Yellow "[ Warn  ]")
          LevelError   -> toLogStr (style Bold $ color Red    "[ Error ]")
          LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
    let out = fromLogStr (l <>  toLogStr " " <> str' <> toLogStr "\n")
    outter out
-
-myLoggerTStdout :: LoggingT m a -> m a
-myLoggerTStdout = myLoggerT (B.hPut stdout)
-
-myLoggerTStderr :: LoggingT m a -> m a
-myLoggerTStderr = myLoggerT (B.hPut stderr)
-
--- a/lib/GHCup/Prelude.hs
+++ b/lib/GHCup/Prelude.hs
@ -14,35 +14,33 @@
 module GHCup.Prelude where

 import           Control.Applicative
+import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      ( lift )
-import           Control.Exception.Safe
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import qualified Data.Strict.Maybe             as S
 import           Data.Monoid                    ( (<>) )
 import           Data.String
+import           Data.Text                      ( Text )
+import           Data.Versions
+import           GHC.Base
+import           Haskus.Utils.Types.List
+import           Haskus.Utils.Variant.Excepts
+import           Language.Haskell.TH
+import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
+import           Language.Haskell.TH.Syntax     ( Exp(..) , Lift)
+import           System.IO.Error

+import qualified Data.ByteString.Lazy          as L
+import qualified Data.Strict.Maybe             as S
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as E
+import qualified Data.Text.Lazy                as TL
 import qualified Data.Text.Lazy.Builder        as B
 import qualified Data.Text.Lazy.Builder.Int    as B
 import qualified Data.Text.Lazy.Encoding       as TLE
-import qualified Data.Text.Lazy                as TL
-import           Data.Text                      ( Text )
-import qualified Data.Text.Encoding            as E
-import qualified Data.Text                     as T
-import           Data.Versions
-import qualified Data.ByteString.Lazy          as L
-import           Haskus.Utils.Types.List
-import           Haskus.Utils.Variant.Excepts
-import           System.IO.Error
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Syntax     ( Exp(..)
-                                                , Lift
-                                                )
 import qualified Language.Haskell.TH.Syntax    as TH
-import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
-import           GHC.Base



--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@ -2,12 +2,13 @@

 module GHCup.Types where

-import           HPath
 import           Data.Map.Strict                ( Map )
-import qualified GHC.Generics                  as GHC
 import           Data.Versions
+import           HPath
 import           URI.ByteString

+import qualified GHC.Generics                  as GHC
+

 data DebugInfo = DebugInfo
  { diBaseDir   :: Path Abs
--- a/lib/GHCup/Types/JSON.hs
+++ b/lib/GHCup/Types/JSON.hs
@ -3,29 +3,29 @@
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE QuasiQuotes           #-}

 module GHCup.Types.JSON where

 import           GHCup.Types
-import           Data.Versions
+
 import           Data.Aeson
 import           Data.Aeson.TH
-import qualified Data.Text                     as T
-import           Data.Text.Encoding             ( decodeUtf8
-                                                , encodeUtf8
-                                                )
 import           Data.Aeson.Types
+import           Data.String.QQ
+import           Data.Text.Encoding             ( decodeUtf8 )
 import           Data.Text.Encoding            as E
+import           Data.Versions
+import           Data.Word8
 import           HPath
 import           URI.ByteString
-import           Data.Word8
+
 import qualified Data.ByteString               as BS
-import           Data.String.QQ
+import qualified Data.Text                     as T



@ -148,4 +148,3 @@ instance FromJSON (Path Rel) where
    case parseRel d of
      Right x -> pure x
      Left  e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
-
--- a/lib/GHCup/Types/Optics.hs
+++ b/lib/GHCup/Types/Optics.hs
@ -2,8 +2,9 @@

 module GHCup.Types.Optics where

-import           Data.ByteString                ( ByteString )
 import           GHCup.Types
+
+import           Data.ByteString                ( ByteString )
 import           Optics
 import           URI.ByteString