git.iko.soy/obelisk
on master help sign in
Update for new hpack
644587fAli Abrar
lib/cliapp/src/Obelisk/CliApp/Types.hs+8−3
compare with master
unifiedsplit
@@ -6,12 +6,14 @@
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
10module Obelisk.CliApp.Types where
11module Obelisk.CliApp.Types where
11
12
12import Control.Concurrent.MVar (MVar)
13import Control.Concurrent.MVar (MVar)
13import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
14import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
15+import Control.Monad.Fail (MonadFail)
14−import Control.Monad.Log (LoggingT, MonadLog, Severity (..), WithSeverity (..), logMessage)
16+import Control.Monad.Log (LoggingT(..), MonadLog, Severity (..), WithSeverity (..), logMessage)
15import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask, mapReaderT)
17import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask, mapReaderT)
16import Control.Monad.Writer (WriterT)
18import Control.Monad.Writer (WriterT)
17import Control.Monad.State (StateT)
19import Control.Monad.State (StateT)
@@ -45,9 +47,12 @@ type CliThrow e m = MonadError e m
45putLog :: CliLog m => Severity -> Text -> m ()
47putLog :: CliLog m => Severity -> Text -> m ()
46putLog sev = logMessage . Output_Log . WithSeverity sev
48putLog sev = logMessage . Output_Log . WithSeverity sev
47
49
50+-- TODO (Re)move this instance
51+deriving instance MonadFail m => MonadFail (LoggingT Output m)
52+
48newtype DieT e m a = DieT { unDieT :: ReaderT (e -> (Text, Int)) (LoggingT Output m) a }
53newtype DieT e m a = DieT { unDieT :: ReaderT (e -> (Text, Int)) (LoggingT Output m) a }
49 deriving
54 deriving
50− ( Functor, Applicative, Monad, MonadIO
55+ ( Functor, Applicative, Monad, MonadIO, MonadFail
51 , MonadThrow, MonadCatch, MonadMask
56 , MonadThrow, MonadCatch, MonadMask
52 , MonadLog Output
57 , MonadLog Output
53 )
58 )
@@ -114,7 +119,7 @@ newtype CliT e m a = CliT
114 { unCliT :: ReaderT (CliConfig e) (DieT e m) a
119 { unCliT :: ReaderT (CliConfig e) (DieT e m) a
115 }
120 }
116 deriving
121 deriving
117− ( Functor, Applicative, Monad, MonadIO
122+ ( Functor, Applicative, Monad, MonadIO, MonadFail
118 , MonadThrow, MonadCatch, MonadMask
123 , MonadThrow, MonadCatch, MonadMask
119 , MonadLog Output -- CliLog
124 , MonadLog Output -- CliLog
120 , MonadError e -- CliThrow
125 , MonadError e -- CliThrow
lib/command/src/Obelisk/App.hs+3−2
@@ -62,10 +62,11 @@ newtype ObeliskT m a = ObeliskT
62 { unObeliskT :: ReaderT Obelisk (CliT ObeliskError m) a
62 { unObeliskT :: ReaderT Obelisk (CliT ObeliskError m) a
63 }
63 }
64 deriving
64 deriving
65− ( Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask
65+ ( Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadFail
66 , MonadLog Output -- CliLog
66 , MonadLog Output -- CliLog
67 , MonadError ObeliskError -- CliThrow ObeliskError
67 , MonadError ObeliskError -- CliThrow ObeliskError
68− , HasCliConfig ObeliskError)
68+ , HasCliConfig ObeliskError
69+ )
69
70
70instance MonadTrans ObeliskT where
71instance MonadTrans ObeliskT where
71 lift = ObeliskT . lift . lift
72 lift = ObeliskT . lift . lift
lib/command/src/Obelisk/Command/Run.hs+2−2
@@ -118,12 +118,12 @@ parseCabalPackage dir = do
118 then Just <$> liftIO (readUTF8File cabalFp)
118 then Just <$> liftIO (readUTF8File cabalFp)
119 else if hasHpack
119 else if hasHpack
120 then do
120 then do
121− let decodeOptions = DecodeOptions hpackFp Nothing decodeYaml
121+ let decodeOptions = DecodeOptions (ProgramName "ob") hpackFp Nothing decodeYaml
122 liftIO (readPackageConfig decodeOptions) >>= \case
122 liftIO (readPackageConfig decodeOptions) >>= \case
123 Left err -> do
123 Left err -> do
124 putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err
124 putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err
125 return Nothing
125 return Nothing
126− Right (DecodeResult hpackPackage _ _) -> do
126+ Right (DecodeResult hpackPackage _ _ _) -> do
127 return $ Just $ renderPackage [] hpackPackage
127 return $ Just $ renderPackage [] hpackPackage
128 else return Nothing
128 else return Nothing
129
129