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
|
module Command (
CommonOptions(..),
defaultCommonOptions,
Command(..),
CommandArgumentsType(..),
CommandExec(..),
CommandInput(..),
getCommonOptions,
getConfigPath,
getConfig,
getRepo, getDefaultRepo,
getTerminalOutput,
) where
import Control.Monad.Except
import Control.Monad.Reader
import Data.Kind
import Data.Text (Text)
import Data.Text 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)
instance MonadFail CommandExec where
fail err = liftIO $ do
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 defalut repo"
getTerminalOutput :: CommandExec TerminalOutput
getTerminalOutput = CommandExec (asks ciTerminalOutput)
|