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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
module Command (
CommonOptions(..),
defaultCommonOptions,
Command(..),
CommandArgumentsType(..),
CommandExec(..),
tfail,
CommandInput(..),
getCommonOptions,
getConfigPath,
getConfig,
getRepo, getDefaultRepo, tryGetDefaultRepo,
getEvalInput,
getTerminalOutput,
getStorageDir,
) 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.FilePath
import System.IO
import Config
import Eval
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
, ciContainingRepo :: Maybe Repo
, ciOtherRepos :: [ ( RepoName, Repo ) ]
, ciTerminalOutput :: TerminalOutput
, ciStorageDir :: Maybe FilePath
}
getCommonOptions :: CommandExec CommonOptions
getCommonOptions = CommandExec (asks ciOptions)
getConfigPath :: CommandExec FilePath
getConfigPath = do
CommandExec (asks ciConfigPath) >>= \case
Nothing -> tfail $ "no job file found"
Just path -> return path
getConfig :: CommandExec Config
getConfig = do
CommandExec (asks ciConfig) >>= \case
Left err -> fail err
Right config -> return config
getRepo :: RepoName -> CommandExec Repo
getRepo name = do
CommandExec (asks (lookup name . ciOtherRepos)) >>= \case
Just repo -> return repo
Nothing -> tfail $ "repo `" <> textRepoName name <> "' not declared"
getDefaultRepo :: CommandExec Repo
getDefaultRepo = do
tryGetDefaultRepo >>= \case
Just repo -> return repo
Nothing -> tfail $ "no default repo"
tryGetDefaultRepo :: CommandExec (Maybe Repo)
tryGetDefaultRepo = CommandExec $ asks ciContainingRepo
getEvalInput :: CommandExec EvalInput
getEvalInput = CommandExec $ do
eiContainingRepo <- asks ciContainingRepo
eiOtherRepos <- asks ciOtherRepos
return EvalInput {..}
getTerminalOutput :: CommandExec TerminalOutput
getTerminalOutput = CommandExec (asks ciTerminalOutput)
getStorageDir :: CommandExec FilePath
getStorageDir = CommandExec (asks ciStorageDir) >>= \case
Just dir -> return dir
Nothing -> ((</> ".minici") . takeDirectory) <$> getConfigPath
|