1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
module Command (
CommonOptions(..),
defaultCommonOptions,
Command(..),
CommandArgumentsType(..),
CommandExec(..),
tfail,
CommandInput(..),
getCommonOptions,
getConfigPath,
getConfig,
getRepo, getDefaultRepo,
getTerminalOutput,
) where
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Reader
import Data.Kind
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import System.Console.GetOpt
import System.Exit
import System.IO
import Config
import Repo
import Terminal
data CommonOptions = CommonOptions
{ optJobs :: Int
, optRepo :: [ DeclaredRepo ]
}
defaultCommonOptions :: CommonOptions
defaultCommonOptions = CommonOptions
{ optJobs = 2
, optRepo = []
}
class CommandArgumentsType (CommandArguments c) => Command c where
commandName :: proxy c -> String
commandDescription :: proxy c -> String
type CommandOptions c :: Type
type CommandOptions c = ()
commandOptions :: proxy c -> [OptDescr (CommandOptions c -> CommandOptions c)]
commandOptions _ = []
defaultCommandOptions :: proxy c -> CommandOptions c
default defaultCommandOptions :: CommandOptions c ~ () => proxy c -> CommandOptions c
defaultCommandOptions _ = ()
type CommandArguments c :: Type
type CommandArguments c = ()
commandUsage :: proxy c -> Text
commandInit :: CommandArgumentsType (CommandArguments c) => proxy c -> CommandOptions c -> CommandArguments c -> c
commandExec :: c -> CommandExec ()
class CommandArgumentsType args where
argsFromStrings :: [String] -> Except String args
instance CommandArgumentsType () where
argsFromStrings [] = return ()
argsFromStrings _ = throwError "no argument expected"
instance CommandArgumentsType Text where
argsFromStrings [str] = return $ T.pack str
argsFromStrings _ = throwError "expected single argument"
instance CommandArgumentsType (Maybe Text) where
argsFromStrings [] = return $ Nothing
argsFromStrings [str] = return $ Just (T.pack str)
argsFromStrings _ = throwError "expected at most one argument"
instance CommandArgumentsType [ Text ] where
argsFromStrings strs = return $ map T.pack strs
newtype CommandExec a = CommandExec (ReaderT CommandInput IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)
instance MonadFail CommandExec where
fail = tfail . T.pack
tfail :: Text -> CommandExec a
tfail err = liftIO $ do
T.hPutStrLn stderr err
exitFailure
data CommandInput = CommandInput
{ ciOptions :: CommonOptions
, ciConfigPath :: Maybe FilePath
, ciConfig :: Either String Config
, ciRepos :: [ ( Maybe RepoName, Repo ) ]
, ciTerminalOutput :: TerminalOutput
}
getCommonOptions :: CommandExec CommonOptions
getCommonOptions = CommandExec (asks ciOptions)
getConfigPath :: CommandExec FilePath
getConfigPath = CommandExec $ do
asks ciConfigPath >>= \case
Nothing -> fail $ "no job file found"
Just path -> return path
getConfig :: CommandExec Config
getConfig = CommandExec $ do
asks ciConfig >>= \case
Left err -> fail err
Right config -> return config
getRepo :: RepoName -> CommandExec Repo
getRepo name = CommandExec $ do
asks (lookup (Just name) . ciRepos) >>= \case
Just repo -> return repo
Nothing -> fail $ "repo `" <> showRepoName name <> "' not declared"
getDefaultRepo :: CommandExec Repo
getDefaultRepo = CommandExec $ do
asks (lookup Nothing . ciRepos) >>= \case
Just repo -> return repo
Nothing -> fail $ "no default repo"
getTerminalOutput :: CommandExec TerminalOutput
getTerminalOutput = CommandExec (asks ciTerminalOutput)
|