This commit is contained in:
Julian Ospald 2020-03-01 01:05:02 +01:00
parent e1fb60d3b1
commit c5699eb641
9 changed files with 143 additions and 130 deletions

View File

@ -8,28 +8,32 @@
module Main where module Main where
import GHCup
import GHCup.File
import GHCup.Logger
import GHCup.Prelude
import GHCup.Types
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Data.Bifunctor import Data.Bifunctor
import qualified Data.ByteString.UTF8 as UTF8
import Data.Char import Data.Char
import Data.List ( intercalate ) import Data.List ( intercalate )
import Data.Semigroup ( (<>) ) import Data.Semigroup ( (<>) )
import Data.String.Interpolate
import Data.String.QQ import Data.String.QQ
import qualified Data.Text as T
import Data.Versions import Data.Versions
import GHCup
import GHCup.Logger
import GHCup.File
import GHCup.Prelude
import GHCup.Types
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import System.Console.Pretty import System.Console.Pretty
import System.Exit import System.Exit
import URI.ByteString import System.IO
import Text.Layout.Table 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 :: IO ()
main = do main = do
-- logger interpreter
let runLogger = myLoggerTStderr
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm) customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \opt@Options {..} -> do >>= \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 -- wrapper to run effects with settings
let runInstTool = let runInstTool =
runLogger runLogger

View File

@ -12,72 +12,78 @@
module GHCup where 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.Bash
import GHCup.File import GHCup.File
import GHCup.Prelude import GHCup.Prelude
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( ) 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
import HPath.IO import HPath.IO
import Haskus.Utils.Variant.Excepts
import Network.Http.Client hiding ( URL )
import Optics import Optics
import Prelude hiding ( abs import Prelude hiding ( abs
, readFile , readFile
) )
import Data.List import Safe
import System.Info
import System.IO.Error 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 as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified Data.Text.ICU as ICU 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 qualified System.IO.Streams as Streams
import System.Posix.FilePath ( takeFileName )
import qualified System.Posix.FilePath as FP 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 import qualified System.Posix.RawFilePath.Directory
as RD 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 data Settings = Settings
@ -674,7 +680,7 @@ setGHC ver sghc = do
-- symlink destination -- symlink destination
destdir <- liftIO $ ghcupBinDir destdir <- liftIO $ ghcupBinDir
liftIO $ createDirIfMissing newDirPerms destdir liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms destdir
-- for ghc tools (ghc, ghci, haddock, ...) -- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver verfiles <- ghcToolFiles ver
@ -898,6 +904,9 @@ getDebugInfo = do
ghcupBaseDir :: IO (Path Abs) ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do ghcupBaseDir = do
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory home <- liftIO getHomeDirectory
pure (home </> ([rel|.ghcup|] :: Path Rel)) pure (home </> ([rel|.ghcup|] :: Path Rel))

View File

@ -6,17 +6,18 @@ module GHCup.Bash
) )
where where
import Language.Bash.Parse import Control.Monad
import Language.Bash.Word import Data.ByteString.UTF8 ( toString )
import Language.Bash.Syntax import Data.List
import Data.Maybe
import HPath import HPath
import HPath.IO import HPath.IO
import Data.ByteString.UTF8 ( toString ) import Language.Bash.Parse
import Control.Monad import Language.Bash.Syntax
import Data.Maybe import Language.Bash.Word
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import Prelude hiding ( readFile ) import Prelude hiding ( readFile )
import Data.List
import qualified Data.ByteString.Lazy.UTF8 as UTF8
extractAssignments :: List -> [Assign] extractAssignments :: List -> [Assign]

View File

@ -3,48 +3,48 @@
module GHCup.File where module GHCup.File where
import Control.Exception.Safe
import Control.Monad
import Data.ByteString import Data.ByteString
import qualified Data.ByteString.Lazy as L import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.Char import Data.Char
import Data.Foldable
import Data.Functor
import Data.Maybe import Data.Maybe
import Data.String.QQ import Data.String.QQ
import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import HPath import HPath
import HPath.IO import HPath.IO
import Optics import Optics
import Streamly
import Streamly.External.ByteString import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy import Streamly.External.ByteString.Lazy
import Streamly import System.Exit
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.IO 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 import "unix" System.Posix.IO.ByteString
hiding ( openFd ) hiding ( openFd )
import qualified System.Posix.Process.ByteString
as SPPB
import System.Posix.Directory.ByteString
import System.Posix.Process ( ProcessStatus(..) ) import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Temp.ByteString import System.Posix.Temp.ByteString
import System.Posix.Types 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 import qualified Streamly.Internal.Memory.ArrayStream
as AS as AS
import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S import qualified Streamly.Prelude as S
import System.Exit
import System.Posix.FD as FD
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen ) import qualified Data.ByteString.Lazy as L
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.Foreign ( peekCStringLen )
data ProcessError = NonZeroExit Int ByteString [ByteString] data ProcessError = NonZeroExit Int ByteString [ByteString]

View File

@ -1,30 +1,28 @@
module GHCup.Logger where module GHCup.Logger where
import System.Console.Pretty
import System.IO
import Control.Monad.Logger import Control.Monad.Logger
import System.Console.Pretty
import qualified Data.ByteString as B import qualified Data.ByteString as B
myLoggerT :: (B.ByteString -> IO ()) -> LoggingT m a -> m a data LoggerConfig = LoggerConfig {
myLoggerT outter loggingt = runLoggingT loggingt mylogger lcPrintDebug :: Bool
, outter :: B.ByteString -> IO ()
}
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT LoggerConfig{..} loggingt = runLoggingT loggingt mylogger
where where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO () mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do mylogger _ _ level str' = do
let l = case level of 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 ]") LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]") LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]") LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]" LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n") let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
outter out outter out
myLoggerTStdout :: LoggingT m a -> m a
myLoggerTStdout = myLoggerT (B.hPut stdout)
myLoggerTStderr :: LoggingT m a -> m a
myLoggerTStderr = myLoggerT (B.hPut stderr)

View File

@ -14,35 +14,33 @@
module GHCup.Prelude where module GHCup.Prelude where
import Control.Applicative import Control.Applicative
import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Exception.Safe
import Data.Bifunctor import Data.Bifunctor
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import qualified Data.Strict.Maybe as S
import Data.Monoid ( (<>) ) import Data.Monoid ( (<>) )
import Data.String 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 as B
import qualified Data.Text.Lazy.Builder.Int as B import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE 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 qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import GHC.Base

View File

@ -2,12 +2,13 @@
module GHCup.Types where module GHCup.Types where
import HPath
import Data.Map.Strict ( Map ) import Data.Map.Strict ( Map )
import qualified GHC.Generics as GHC
import Data.Versions import Data.Versions
import HPath
import URI.ByteString import URI.ByteString
import qualified GHC.Generics as GHC
data DebugInfo = DebugInfo data DebugInfo = DebugInfo
{ diBaseDir :: Path Abs { diBaseDir :: Path Abs

View File

@ -3,29 +3,29 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Types.JSON where module GHCup.Types.JSON where
import GHCup.Types import GHCup.Types
import Data.Versions
import Data.Aeson import Data.Aeson
import Data.Aeson.TH import Data.Aeson.TH
import qualified Data.Text as T
import Data.Text.Encoding ( decodeUtf8
, encodeUtf8
)
import Data.Aeson.Types import Data.Aeson.Types
import Data.String.QQ
import Data.Text.Encoding ( decodeUtf8 )
import Data.Text.Encoding as E import Data.Text.Encoding as E
import Data.Versions
import Data.Word8
import HPath import HPath
import URI.ByteString import URI.ByteString
import Data.Word8
import qualified Data.ByteString as BS 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 case parseRel d of
Right x -> pure x Right x -> pure x
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e

View File

@ -2,8 +2,9 @@
module GHCup.Types.Optics where module GHCup.Types.Optics where
import Data.ByteString ( ByteString )
import GHCup.Types import GHCup.Types
import Data.ByteString ( ByteString )
import Optics import Optics
import URI.ByteString import URI.ByteString