Yo

2020-03-01 00:07:39 +01:00
parent 6489e8430b
commit e1fb60d3b1
11 changed files with 298 additions and 253 deletions
--- a/lib/GHCup/File.hs
+++ b/lib/GHCup/File.hs
@@ -19,7 +19,6 @@ import           Data.Foldable
 import           Control.Monad
 import           Control.Exception.Safe
 import           Data.Functor
-import           System.Posix.Files.ByteString
 import           System.Posix.Foreign           ( oExcl )
 import           System.Posix.Env.ByteString
 import           System.IO
@@ -40,12 +39,6 @@ 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 qualified Streamly.Data.Fold            as FL
-import           Data.ByteString.Builder
-import           Foreign.C.Error
-import           GHCup.Prelude
-import           Control.Concurrent.Async
-import           Control.Concurrent
 import           System.Posix.FD               as FD
 import qualified Data.ByteString.UTF8          as UTF8
 import           Data.ByteString.Unsafe         ( unsafeUseAsCStringLen )
@@ -61,11 +54,12 @@ data ProcessError = NonZeroExit Int ByteString [ByteString]
                  deriving Show


-data CapturedProcess = CapturedProcess {
-    _exitCode :: ExitCode
+data CapturedProcess = CapturedProcess
+  { _exitCode :: ExitCode
  , _stdOut   :: ByteString
  , _stdErr   :: ByteString
-} deriving (Eq, Show)
+  }
+  deriving (Eq, Show)

 makeLenses ''CapturedProcess

@@ -101,7 +95,7 @@ findExecutable ex = do
  -- figure out if a file exists, then treat it as a negative result.
  asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
    -- asum for short-circuiting behavior
-    (\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
+    (\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
    sPaths


@@ -111,10 +105,9 @@ executeOut :: Path b          -- ^ command as filename, e.g. 'ls'
           -> [ByteString]      -- ^ arguments to the command
           -> Maybe (Path Abs)  -- ^ chdir to this path
           -> IO CapturedProcess
-executeOut path args chdir =
-  captureOutStreams $ do
-   maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
-   SPPB.executeFile (toFilePath path) True args Nothing
+executeOut path args chdir = captureOutStreams $ do
+  maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+  SPPB.executeFile (toFilePath path) True args Nothing


 -- | Capture the stdout and stderr of the given action, which
@@ -150,9 +143,9 @@ captureOutStreams action =
          stdout' <- L.toStrict <$> readFd parentStdoutRead
          stderr' <- L.toStrict <$> readFd parentStderrRead
          pure $ CapturedProcess { _exitCode = es
-                                        , _stdOut   = stdout'
-                                        , _stdErr   = stderr'
-                                        }
+                                 , _stdOut   = stdout'
+                                 , _stdErr   = stderr'
+                                 }
        _ -> throwIO $ userError $ ("No such PID " ++ show pid)

 where
--- a/lib/GHCup/Logger.hs
+++ b/lib/GHCup/Logger.hs
@@ -1,30 +1,10 @@
 module GHCup.Logger where


-import           GHCup
-import           GHCup.Types
-import           GHCup.Types.Optics
-
-import           Control.Monad
-import           Control.Exception.Safe
-import           Control.Monad.Reader.Class
-import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Class      ( lift )
-import           Control.Monad.Trans.Reader     ( ReaderT
-                                                , runReaderT
-                                                )
-import           Data.List
-import           Data.String.QQ
-import           Data.String.Interpolate
-import           Data.Versions
-import           Data.IORef
-import           Optics
-import           System.Exit
 import           System.Console.Pretty
 import           System.IO
 import           Control.Monad.Logger

-import qualified Data.Map.Strict               as M
 import qualified Data.ByteString as B


@@ -32,14 +12,14 @@ myLoggerT :: (B.ByteString -> IO ()) -> LoggingT m a -> m a
 myLoggerT outter loggingt = runLoggingT loggingt mylogger
 where
  mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
-  mylogger loc source level str = do
+  mylogger _ _ level str' = do
    let l = case level of
          LevelDebug   -> toLogStr (style Bold $ color Blue   "[ Debug ]")
          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")
+    let out = fromLogStr (l <>  toLogStr " " <> str' <> toLogStr "\n")
    outter out

 myLoggerTStdout :: LoggingT m a -> m a
--- a/lib/GHCup/Prelude.hs
+++ b/lib/GHCup/Prelude.hs
@@ -15,6 +15,7 @@ module GHCup.Prelude where

 import           Control.Applicative
 import           Control.Monad
+import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      ( lift )
 import           Control.Exception.Safe
 import           Data.Bifunctor
@@ -23,8 +24,8 @@ import qualified Data.Strict.Maybe             as S
 import           Data.Monoid                    ( (<>) )
 import           Data.String

-import qualified Data.Text.Lazy.Builder as B
-import qualified Data.Text.Lazy.Builder.Int as B
+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 )
@@ -32,6 +33,7 @@ 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
@@ -99,9 +101,14 @@ lBS2sT :: L.ByteString -> Text
 lBS2sT = TL.toStrict . TLE.decodeUtf8


-handleIO' :: IOErrorType -> (IOException -> IO a) -> IO a -> IO a
-handleIO' err handler =
-  handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e)
+
+handleIO' :: (MonadIO m, MonadCatch m)
+          => IOErrorType
+          -> (IOException -> m a)
+          -> m a
+          -> m a
+handleIO' err handler = handleIO
+  (\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)


 (??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
@@ -139,14 +146,34 @@ lEM' f em = lift em >>= lE . bimap f id
 fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight

+
+liftException :: ( MonadCatch m
+                 , MonadIO m
+                 , Monad m
+                 , e :< es'
+                 , LiftVariant es es'
+                 )
+              => IOErrorType
+              -> e
+              -> Excepts es m a
+              -> Excepts es' m a
+liftException errType ex =
+  handleIO
+      (\e ->
+        if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
+      )
+    . liftE
+
+
+-- TODO: does this work?
 hideExcept :: forall e es es' a m
            . (Monad m, e :< es, LiftVariant (Remove e es) es')
           => e
           -> a
           -> Excepts es m a
           -> Excepts es' m a
-hideExcept h a action =
-  catchLiftLeft ((\(x@e) -> pure a) :: (e -> Excepts es' m a)) action
+hideExcept _ a action =
+  catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action


 throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
@@ -177,8 +204,8 @@ qq quoteExp' = QuasiQuoter
    "illegal QuasiQuote (allowed as expression only, used as a declaration)"
  }

-ver :: QuasiQuoter
-ver = qq mkV
+vver :: QuasiQuoter
+vver = qq mkV
 where
  mkV :: Text -> Q Exp
  mkV = either (fail . show) TH.lift . version
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@@ -9,9 +9,21 @@ import           Data.Versions
 import           URI.ByteString


+data DebugInfo = DebugInfo
+  { diBaseDir   :: Path Abs
+  , diBinDir    :: Path Abs
+  , diGHCDir    :: Path Abs
+  , diCacheDir  :: Path Abs
+  , diURLSource :: URLSource
+  , diArch      :: Architecture
+  , diPlatform  :: PlatformResult
+  }
+  deriving Show
+
+
 data SetGHC = SetGHCOnly  -- ^ unversioned 'ghc'
            | SetGHCMajor -- ^ ghc-x.y
-            | SetGHCMinor -- ^ ghc-x.y.z
+            | SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename
            deriving Show


@@ -33,11 +45,12 @@ data DownloadInfo = DownloadInfo

 data Tool = GHC
          | Cabal
+          | GHCUp
  deriving (Eq, GHC.Generic, Ord, Show)

 data ToolRequest = ToolRequest
-  { _tool        :: Tool
-  , _toolVersion :: Version
+  { _trTool        :: Tool
+  , _trVersion :: Version
  }
  deriving (Eq, Show)