Lol

lib/GHCup/File.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module GHCup.File where
@@ -6,6 +7,7 @@ import           Data.ByteString
 import qualified Data.ByteString.Lazy          as L
 import           Data.Char
 import           Data.Maybe
+import           Data.String.QQ
 import           HPath
 import           HPath.IO
 import           Optics
@@ -19,14 +21,18 @@ 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
+import qualified System.Posix.FilePath         as FP
 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 Streamly.Internal.Memory.ArrayStream
                                                as AS
@@ -41,12 +47,17 @@ 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 )
+import           GHC.IO.Encoding                ( getLocaleEncoding )
+import           GHC.Foreign                    ( peekCStringLen )
 
 
-data ProcessError = NonZeroExit Int
-                  | PTerminated
-                  | PStopped
-                  | NoSuchPid
+
+data ProcessError = NonZeroExit Int ByteString [ByteString]
+                  | PTerminated ByteString [ByteString]
+                  | PStopped ByteString [ByteString]
+                  | NoSuchPid ByteString [ByteString]
                   deriving Show
 
 
@@ -169,13 +180,41 @@ exec exe args spath chdir = do
     maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
     SPPB.executeFile exe spath args Nothing
 
-  fmap toProcessError $ SPPB.getProcessStatus True True pid
+  fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
 
 
-toProcessError :: Maybe ProcessStatus -> Either ProcessError ()
-toProcessError mps = case mps of
-  Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i
+toProcessError :: ByteString
+               -> [ByteString]
+               -> Maybe ProcessStatus
+               -> Either ProcessError ()
+toProcessError exe args mps = case mps of
+  Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
   Just (SPPB.Exited ExitSuccess    ) -> Right ()
-  Just (Terminated _ _             ) -> Left $ PTerminated
-  Just (Stopped _                  ) -> Left $ PStopped
-  Nothing                            -> Left $ NoSuchPid
+  Just (Terminated _ _             ) -> Left $ PTerminated exe args
+  Just (Stopped _                  ) -> Left $ PStopped exe args
+  Nothing                            -> Left $ NoSuchPid exe args
+
+
+mkGhcupTmpDir :: IO (Path Abs)
+mkGhcupTmpDir = do
+  tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|]
+  tmp    <- mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
+  parseAbs tmp
+
+
+getHomeDirectory :: IO (Path Abs)
+getHomeDirectory = do
+  e <- getEnv [s|HOME|]
+  case e of
+    Just fp -> parseAbs fp
+    Nothing -> do
+      h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
+      parseAbs $ UTF8.fromString h -- this is a guess
+
+
+-- | Convert the String to a ByteString with the current
+-- system encoding.
+unsafePathToString :: Path b -> IO FilePath
+unsafePathToString (Path p) = do
+  enc <- getLocaleEncoding
+  unsafeUseAsCStringLen p (peekCStringLen enc)

lib/GHCup/Prelude.hs

@@ -3,6 +3,9 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module GHCup.Prelude where
 
@@ -10,15 +13,23 @@ import           Control.Applicative
 import           Control.Monad
 import           Control.Monad.Trans.Class      ( lift )
 import           Control.Exception.Safe
+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           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
 
 
 
@@ -44,6 +55,9 @@ iE :: String -> IO a
 iE = internalError
 
 
+showT :: Show a => a -> Text
+showT = fS . show
+
 -- | Like 'when', but where the test can be monadic.
 whenM :: Monad m => m Bool -> m () -> m ()
 whenM ~b ~t = ifM b t (return ())
@@ -99,3 +113,58 @@ lEM em = lift em >>= lE
 
 fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
+
+
+
+deriving instance Lift Versioning
+deriving instance Lift Version
+deriving instance Lift SemVer
+deriving instance Lift Mess
+deriving instance Lift PVP
+deriving instance Lift (NonEmpty Word)
+deriving instance Lift VSep
+deriving instance Lift VUnit
+instance Lift Text
+
+qq :: (Text -> Q Exp) -> QuasiQuoter
+qq quoteExp' =
+  QuasiQuoter
+  { quoteExp  = (\s -> quoteExp' . T.pack $ s)
+  , quotePat  = \_ ->
+      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)"
+  }
+
+ver :: QuasiQuoter
+ver = qq mkV
+  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
+
+sver :: QuasiQuoter
+sver = qq mkV
+  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
+
+pver :: QuasiQuoter
+pver = qq mkV
+  where
+    mkV :: Text -> Q Exp
+    mkV = either (fail . show) TH.lift . pvp
+

lib/GHCup/Types.hs

@@ -2,15 +2,29 @@
 
 module GHCup.Types where
 
+import           HPath
 import           Data.Map.Strict                ( Map )
 import qualified GHC.Generics                  as GHC
 import           Data.Versions
 import           URI.ByteString
 
 
+data Tag = Latest
+         | Recommended
+         deriving (Eq, Show)
+
+data VersionInfo = VersionInfo {
+    _viTags :: [Tag]
+  , _viArch :: ArchitectureSpec
+} deriving (Eq, Show)
+
+data DownloadInfo = DownloadInfo {
+    _dlUri    :: URI
+  , _dlSubdir :: Maybe (Path Rel)
+} deriving (Eq, Show)
+
 data Tool = GHC
           | Cabal
-          | Stack
   deriving (Eq, GHC.Generic, Ord, Show)
 
 data ToolRequest = ToolRequest {
@@ -55,13 +69,14 @@ data PlatformRequest = PlatformRequest {
   , _rVersion :: Maybe Versioning
 } deriving (Eq, Show)
 
-type PlatformVersionSpec = Map (Maybe Versioning) URI
+type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
 type PlatformSpec = Map Platform PlatformVersionSpec
 type ArchitectureSpec = Map Architecture PlatformSpec
-type ToolVersionSpec = Map Version ArchitectureSpec
+type ToolVersionSpec = Map Version VersionInfo
 type AvailableDownloads = Map Tool ToolVersionSpec
 
 
 data URLSource = GHCupURL
                | OwnSource URI
                | OwnSpec AvailableDownloads
+               deriving Show

lib/GHCup/Types/Optics.hs

@@ -11,9 +11,13 @@ makePrisms ''Tool
 makePrisms ''Architecture
 makePrisms ''LinuxDistro
 makePrisms ''Platform
+makePrisms ''Tag
 
 makeLenses ''PlatformResult
 makeLenses ''ToolRequest
+makeLenses ''DownloadInfo
+makeLenses ''Tag
+makeLenses ''VersionInfo
 
 
 uriSchemeL' :: Lens' (URIRef Absolute) Scheme