More

lib/GHCup/File.hs

@@ -107,13 +107,14 @@ findExecutable ex = do
 
 -- | Execute the given command and collect the stdout, stderr and the exit code.
 -- The command is run in a subprocess.
-executeOut :: Path Rel          -- ^ command as filename, e.g. 'ls'
+executeOut :: Path b          -- ^ command as filename, e.g. 'ls'
            -> [ByteString]      -- ^ arguments to the command
            -> Maybe (Path Abs)  -- ^ chdir to this path
-           -> IO (Maybe CapturedProcess)
-executeOut path args chdir = withRelPath path $ \fp -> captureOutStreams $ do
-  maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
-  SPPB.executeFile fp True args Nothing
+           -> IO CapturedProcess
+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
@@ -121,7 +122,7 @@ executeOut path args chdir = withRelPath path $ \fp -> captureOutStreams $ do
 -- 'race' this to make sure it terminates.
 captureOutStreams :: IO a
                      -- ^ the action to execute in a subprocess
-                  -> IO (Maybe CapturedProcess) -- TODO: shouldn't be maybe
+                  -> IO CapturedProcess
 captureOutStreams action =
   actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
     actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
@@ -148,14 +149,11 @@ captureOutStreams action =
         Just (SPPB.Exited es) -> do
           stdout' <- L.toStrict <$> readFd parentStdoutRead
           stderr' <- L.toStrict <$> readFd parentStderrRead
-          pure $ Just $ CapturedProcess { _exitCode = es
+          pure $ CapturedProcess { _exitCode = es
                                         , _stdOut   = stdout'
                                         , _stdErr   = stderr'
                                         }
-        _ -> do
-          closeFd parentStdoutRead
-          closeFd parentStderrRead
-          pure $ Nothing
+        _ -> throwIO $ userError $ ("No such PID " ++ show pid)
 
  where
   actionWithPipes a =

lib/GHCup/Prelude.hs

@@ -6,6 +6,10 @@
 {-# LANGUAGE DeriveLift #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module GHCup.Prelude where
 
@@ -13,23 +17,25 @@ import           Control.Applicative
 import           Control.Monad
 import           Control.Monad.Trans.Class      ( lift )
 import           Control.Exception.Safe
-import           Data.ByteString (ByteString)
+import           Data.ByteString                ( ByteString )
 import qualified Data.Strict.Maybe             as S
 import           Data.Monoid                    ( (<>) )
 import           Data.String
 import qualified Data.Text.Lazy.Encoding       as TLE
 import qualified Data.Text.Lazy                as TL
 import           Data.Text                      ( Text )
-import qualified Data.Text as T
+import qualified Data.Text                     as T
 import           Data.Versions
 import qualified Data.ByteString.Lazy          as L
 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
+import           Language.Haskell.TH.Syntax     ( Exp(..)
+                                                , Lift
+                                                )
+import qualified Language.Haskell.TH.Syntax    as TH
+import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
+import           GHC.Base
 
 
 
@@ -114,6 +120,15 @@ lEM em = lift em >>= lE
 fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
 
+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
+
 
 
 deriving instance Lift Versioning
@@ -127,44 +142,42 @@ deriving instance Lift VUnit
 instance Lift Text
 
 qq :: (Text -> Q Exp) -> QuasiQuoter
-qq quoteExp' =
-  QuasiQuoter
+qq quoteExp' = QuasiQuoter
   { quoteExp  = (\s -> quoteExp' . T.pack $ s)
   , quotePat  = \_ ->
-      fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
+    fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
   , quoteType = \_ ->
-      fail "illegal QuasiQuote (allowed as expression only, used as a type)"
-  , quoteDec  = \_ ->
-      fail "illegal QuasiQuote (allowed as expression only, used as a declaration)"
+    fail "illegal QuasiQuote (allowed as expression only, used as a type)"
+  , quoteDec  = \_ -> fail
+    "illegal QuasiQuote (allowed as expression only, used as a declaration)"
   }
 
 ver :: QuasiQuoter
 ver = qq mkV
-  where
-    mkV :: Text -> Q Exp
-    mkV = either (fail . show) TH.lift . version
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) TH.lift . version
 
 mver :: QuasiQuoter
 mver = qq mkV
-  where
-    mkV :: Text -> Q Exp
-    mkV = either (fail . show) TH.lift . mess
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) TH.lift . mess
 
 sver :: QuasiQuoter
 sver = qq mkV
-  where
-    mkV :: Text -> Q Exp
-    mkV = either (fail . show) TH.lift . semver
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) TH.lift . semver
 
 vers :: QuasiQuoter
 vers = qq mkV
-  where
-    mkV :: Text -> Q Exp
-    mkV = either (fail . show) TH.lift . versioning
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) TH.lift . versioning
 
 pver :: QuasiQuoter
 pver = qq mkV
-  where
-    mkV :: Text -> Q Exp
-    mkV = either (fail . show) TH.lift . pvp
-
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) TH.lift . pvp

lib/GHCup/Types.hs

@@ -9,28 +9,37 @@ import           Data.Versions
 import           URI.ByteString
 
 
+data SetGHC = SetGHCOnly  -- ^ unversioned 'ghc'
+            | SetGHCMajor -- ^ ghc-x.y
+            | SetGHCMinor -- ^ ghc-x.y.z
+            deriving Show
+
+
 data Tag = Latest
          | Recommended
          deriving (Eq, Show)
 
-data VersionInfo = VersionInfo {
-    _viTags :: [Tag]
+data VersionInfo = VersionInfo
+  { _viTags :: [Tag]
   , _viArch :: ArchitectureSpec
-} deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
-data DownloadInfo = DownloadInfo {
-    _dlUri    :: URI
+data DownloadInfo = DownloadInfo
+  { _dlUri    :: URI
   , _dlSubdir :: Maybe (Path Rel)
-} deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 data Tool = GHC
           | Cabal
   deriving (Eq, GHC.Generic, Ord, Show)
 
-data ToolRequest = ToolRequest {
-    _tool :: Tool
+data ToolRequest = ToolRequest
+  { _tool        :: Tool
   , _toolVersion :: Version
-} deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 data Architecture = A_64
                   | A_32
@@ -58,16 +67,18 @@ data Platform = Linux LinuxDistro
               | FreeBSD
   deriving (Eq, GHC.Generic, Ord, Show)
 
-data PlatformResult = PlatformResult {
-    _platform :: Platform
+data PlatformResult = PlatformResult
+  { _platform      :: Platform
   , _distroVersion :: Maybe Versioning
-} deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
-data PlatformRequest = PlatformRequest {
-    _rArch :: Architecture
+data PlatformRequest = PlatformRequest
+  { _rArch     :: Architecture
   , _rPlatform :: Platform
-  , _rVersion :: Maybe Versioning
-} deriving (Eq, Show)
+  , _rVersion  :: Maybe Versioning
+  }
+  deriving (Eq, Show)
 
 type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
 type PlatformSpec = Map Platform PlatformVersionSpec