More stuff

lib/GHCup/Logger.hs

@@ -0,0 +1,50 @@
+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
+
+
+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
+    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")
+    outter out
+
+myLoggerTStdout :: LoggingT m a -> m a
+myLoggerTStdout = myLoggerT (B.hPut stdout)
+
+myLoggerTStderr :: LoggingT m a -> m a
+myLoggerTStderr = myLoggerT (B.hPut stderr)
+

lib/GHCup/Prelude.hs

@@ -17,13 +17,18 @@ import           Control.Applicative
 import           Control.Monad
 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 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
@@ -94,7 +99,7 @@ lBS2sT :: L.ByteString -> Text
 lBS2sT = TL.toStrict . TLE.decodeUtf8
 
 
-handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO ()
+handleIO' :: IOErrorType -> (IOException -> IO a) -> IO a -> IO a
 handleIO' err handler =
   handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e)
 
@@ -114,9 +119,23 @@ handleIO' err handler =
 lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
 lE = liftE . veitherToExcepts . fromEither
 
+lE' :: forall e' e es a m
+     . (Monad m, e :< es)
+    => (e' -> e)
+    -> Either e' a
+    -> Excepts es m a
+lE' f = liftE . veitherToExcepts . fromEither . bimap f id
+
 lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
 lEM em = lift em >>= lE
 
+lEM' :: forall e' e es a m
+      . (Monad m, e :< es)
+     => (e' -> e)
+     -> m (Either e' a)
+     -> Excepts es m a
+lEM' f em = lift em >>= lE . bimap f id
+
 fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
 
@@ -130,6 +149,12 @@ hideExcept h a action =
   catchLiftLeft ((\(x@e) -> pure a) :: (e -> Excepts es' m a)) action
 
 
+throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
+throwEither a = case a of
+  Left  e -> throwM e
+  Right r -> pure r
+
+
 
 deriving instance Lift Versioning
 deriving instance Lift Version
@@ -181,3 +206,12 @@ pver = qq mkV
  where
   mkV :: Text -> Q Exp
   mkV = either (fail . show) TH.lift . pvp
+
+
+verToBS :: Version -> ByteString
+verToBS = E.encodeUtf8 . prettyVer
+
+
+
+intToText :: Integral a => a -> T.Text
+intToText = TL.toStrict . B.toLazyText . B.decimal

lib/GHCup/Types.hs

@@ -17,7 +17,7 @@ data SetGHC = SetGHCOnly  -- ^ unversioned 'ghc'
 
 data Tag = Latest
          | Recommended
-         deriving (Eq, Show)
+         deriving (Ord, Eq, Show)
 
 data VersionInfo = VersionInfo
   { _viTags :: [Tag]

lib/GHCup/Types/JSON.hs

@@ -6,7 +6,8 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE QuasiQuotes           #-}
 
 module GHCup.Types.JSON where
 
@@ -20,7 +21,11 @@ import           Data.Text.Encoding             ( decodeUtf8
                                                 )
 import           Data.Aeson.Types
 import           Data.Text.Encoding            as E
+import           HPath
 import           URI.ByteString
+import           Data.Word8
+import qualified Data.ByteString               as BS
+import           Data.String.QQ
 
 
 
@@ -33,6 +38,9 @@ deriveJSON defaultOptions ''SemVer
 deriveJSON defaultOptions ''Tool
 deriveJSON defaultOptions ''VSep
 deriveJSON defaultOptions ''VUnit
+deriveJSON defaultOptions ''VersionInfo
+deriveJSON defaultOptions ''Tag
+deriveJSON defaultOptions ''DownloadInfo
 
 
 instance ToJSON URI where
@@ -127,3 +135,17 @@ instance ToJSONKey Tool where
 
 instance FromJSONKey Tool where
   fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
+
+instance ToJSON (Path Rel) where
+  toJSON p = case and . fmap isAscii . BS.unpack $ fp of
+    True  -> toJSON . E.decodeUtf8 $ fp
+    False -> String [s|/not/a/valid/path|]
+    where fp = toFilePath p
+
+instance FromJSON (Path Rel) where
+  parseJSON = withText "HPath Rel" $ \t -> do
+    let d = encodeUtf8 t
+    case parseRel d of
+      Right x -> pure x
+      Left  e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
+