]> Git — Sourcephile - haskell/symantic-cli.git/blob - Symantic/CLI/API.hs
3f6763b0a601a69fa042100994d0f2c5952bde4b
[haskell/symantic-cli.git] / Symantic / CLI / API.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE DataKinds #-}
3 {-# LANGUAGE DefaultSignatures #-}
4 {-# LANGUAGE TypeFamilyDependencies #-}
5 {-# LANGUAGE UndecidableInstances #-} -- for type instance defaults
6 module Symantic.CLI.API where
7
8 import Data.Bool
9 import Data.Char (Char)
10 import Data.Eq (Eq)
11 import Data.Function (($), (.), id)
12 import Data.Kind (Constraint)
13 import Data.Maybe (Maybe(..), fromJust)
14 import Data.String (String, IsString(..))
15 import Text.Show (Show)
16
17 -- * Class 'App'
18 class App repr where
19 (<.>) :: repr a b -> repr b c -> repr a c
20 -- Trans defaults
21 default (<.>) ::
22 Trans repr =>
23 App (UnTrans repr) =>
24 repr a b -> repr b c -> repr a c
25 x <.> y = noTrans (unTrans x <.> unTrans y)
26 infixr 4 <.>
27
28 -- * Class 'Alt'
29 class Alt repr where
30 (<!>) :: repr a k -> repr b k -> repr (a:!:b) k
31 alt :: repr a k -> repr a k -> repr a k
32 opt :: repr (a->k) k -> repr (Maybe a->k) k
33 -- Trans defaults
34 default (<!>) ::
35 Trans repr =>
36 Alt (UnTrans repr) =>
37 repr a k -> repr b k -> repr (a:!:b) k
38 default alt ::
39 Trans repr =>
40 Alt (UnTrans repr) =>
41 repr a k -> repr a k -> repr a k
42 default opt ::
43 Trans repr =>
44 Alt (UnTrans repr) =>
45 repr (a->k) k -> repr (Maybe a->k) k
46 x <!> y = noTrans (unTrans x <!> unTrans y)
47 x `alt` y = noTrans (unTrans x `alt` unTrans y)
48 opt = noTrans . opt . unTrans
49 -- NOTE: yes infixr, not infixl like <|>,
50 -- in order to run left-most checks first.
51 infixr 3 <!>
52 infixr 3 `alt`
53
54 -- ** Type (':!:')
55 -- | Like @(,)@ but @infixr@.
56 data (:!:) a b = a:!:b
57 infixr 3 :!:
58
59 -- * Class 'Pro'
60 class Pro repr where
61 dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
62 -- Trans defaults
63 default dimap ::
64 Trans repr =>
65 Pro (UnTrans repr) =>
66 (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
67 dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
68
69 -- * Class 'AltApp'
70 class AltApp repr where
71 many0 :: repr (a->k) k -> repr ([a]->k) k
72 many1 :: repr (a->k) k -> repr ([a]->k) k
73 -- Trans defaults
74 default many0 ::
75 Trans repr =>
76 AltApp (UnTrans repr) =>
77 repr (a->k) k -> repr ([a]->k) k
78 default many1 ::
79 Trans repr =>
80 AltApp (UnTrans repr) =>
81 repr (a->k) k -> repr ([a]->k) k
82 many0 = noTrans . many0 . unTrans
83 many1 = noTrans . many1 . unTrans
84
85 -- * Class 'Permutable'
86 class Permutable repr where
87 -- NOTE: Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
88 type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
89 type Permutation repr = Permutation (UnTrans repr)
90 runPermutation :: Permutation repr k a -> repr (a->k) k
91 toPermutation :: repr (a->k) k -> Permutation repr k a
92 toPermDefault :: a -> repr (a->k) k -> Permutation repr k a
93
94 -- | Convenient wrapper to omit a 'runPermutation'.
95 --
96 -- @
97 -- opts '<?>' next = 'runPermutation' opts '<.>' next
98 -- @
99 (<?>) ::
100 App repr => Permutable repr =>
101 Permutation repr b a -> repr b c -> repr (a->b) c
102 opts <?> next = runPermutation opts <.> next
103 infixr 4 <?>
104
105 -- * Class 'Sequenceable'
106 class Sequenceable repr where
107 -- NOTE: Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
108 type Sequence (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
109 type Sequence repr = Sequence (UnTrans repr)
110 runSequence :: Sequence repr k a -> repr (a->k) k
111 toSequence :: repr (a->k) k -> Sequence repr k a
112
113 -- * Type 'Name'
114 type Name = String
115
116 -- * Type 'Segment'
117 type Segment = String
118
119 -- * Class 'CLI_Command'
120 class CLI_Command repr where
121 command :: Name -> repr a k -> repr a k
122
123 -- * Class 'CLI_Var'
124 class CLI_Var repr where
125 type VarConstraint repr a :: Constraint
126 var' :: VarConstraint repr a => Name -> repr (a->k) k
127 -- Trans defaults
128 type VarConstraint repr a = VarConstraint (UnTrans repr) a
129 default var' ::
130 Trans repr =>
131 CLI_Var (UnTrans repr) =>
132 VarConstraint (UnTrans repr) a =>
133 Name -> repr (a->k) k
134 var' = noTrans . var'
135
136 -- | Like 'var'' but with the type variable @(a)@ first instead or @(repr)@
137 -- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
138 var ::
139 forall a k repr.
140 CLI_Var repr =>
141 VarConstraint repr a =>
142 Name -> repr (a->k) k
143 var = var'
144 {-# INLINE var #-}
145
146 -- * Class 'CLI_Var'
147 class CLI_Constant repr where
148 constant :: Segment -> a -> repr (a->k) k
149 just :: a -> repr (a->k) k
150 nothing :: repr k k
151 default constant ::
152 Trans repr =>
153 CLI_Constant (UnTrans repr) =>
154 Segment -> a -> repr (a->k) k
155 default just ::
156 Trans repr =>
157 CLI_Constant (UnTrans repr) =>
158 a -> repr (a->k) k
159 default nothing ::
160 Trans repr =>
161 CLI_Constant (UnTrans repr) =>
162 repr k k
163 constant s = noTrans . constant s
164 just = noTrans . just
165 nothing = noTrans nothing
166
167 -- * Class 'CLI_Env'
168 class CLI_Env repr where
169 type EnvConstraint repr a :: Constraint
170 env' :: EnvConstraint repr a => Name -> repr (a->k) k
171 -- Trans defaults
172 type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
173 default env' ::
174 Trans repr =>
175 CLI_Env (UnTrans repr) =>
176 EnvConstraint (UnTrans repr) a =>
177 Name -> repr (a->k) k
178 env' = noTrans . env'
179
180 -- | Like 'env'' but with the type enviable @(a)@ first instead or @(repr)@
181 -- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
182 env ::
183 forall a k repr.
184 CLI_Env repr =>
185 EnvConstraint repr a =>
186 Name -> repr (a->k) k
187 env = env'
188 {-# INLINE env #-}
189
190 -- ** Type 'Tag'
191 data Tag
192 = Tag Char Name
193 | TagLong Name
194 | TagShort Char
195 deriving (Eq, Show)
196 instance IsString Tag where
197 fromString = \case
198 [c] -> TagShort c
199 c:'|':cs -> Tag c cs
200 cs -> TagLong cs
201
202 -- * Class 'CLI_Tag'
203 class (App repr, Permutable repr, CLI_Constant repr) => CLI_Tag repr where
204 type TagConstraint repr a :: Constraint
205 tag :: Tag -> repr f k -> repr f k
206 -- tag n = (tag n <.>)
207 endOpts :: repr k k
208
209 flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
210 flag n = toPermDefault False $ tag n $ just True
211
212 optionalTag ::
213 TagConstraint repr a => AltApp repr => Alt repr => Pro repr =>
214 Tag -> repr (a->k) k -> Permutation repr k (Maybe a)
215 optionalTag n = toPermDefault Nothing . tag n . dimap Just fromJust
216
217 defaultTag ::
218 TagConstraint repr a =>
219 Tag -> a -> repr (a->k) k -> Permutation repr k a
220 defaultTag n a = toPermDefault a . tag n
221
222 requiredTag ::
223 TagConstraint repr a =>
224 Tag -> repr (a->k) k -> Permutation repr k a
225 requiredTag n = toPermutation . tag n
226
227 many0Tag ::
228 TagConstraint repr a => AltApp repr =>
229 Tag -> repr (a->k) k -> Permutation repr k [a]
230 many0Tag n = toPermDefault [] . many1 . tag n
231 many1Tag ::
232 TagConstraint repr a => AltApp repr =>
233 Tag -> repr (a->k) k -> Permutation repr k [a]
234 many1Tag n = toPermutation . many1 . tag n
235
236 -- Trans defaults
237 type TagConstraint repr a = TagConstraint (UnTrans repr) a
238 default tag ::
239 Trans repr =>
240 CLI_Tag (UnTrans repr) =>
241 Tag -> repr f k -> repr f k
242 default endOpts ::
243 Trans repr =>
244 CLI_Tag (UnTrans repr) =>
245 repr k k
246 tag n = noTrans . tag n . unTrans
247 endOpts = noTrans endOpts
248
249 -- * Class 'CLI_Response'
250 class CLI_Response repr where
251 type ResponseConstraint repr a :: Constraint
252 type ResponseArgs repr a :: * -- = (r:: *) | r -> a
253 type Response repr :: *
254 response' ::
255 ResponseConstraint repr a =>
256 repr (ResponseArgs repr a)
257 (Response repr)
258 -- Trans defaults
259 type ResponseConstraint repr a = ResponseConstraint (UnTrans repr) a
260 type ResponseArgs repr a = ResponseArgs (UnTrans repr) a
261 type Response repr = Response (UnTrans repr)
262 default response' ::
263 forall a.
264 Trans repr =>
265 CLI_Response (UnTrans repr) =>
266 ResponseConstraint (UnTrans repr) a =>
267 ResponseArgs repr a ~ ResponseArgs (UnTrans repr) a =>
268 Response repr ~ Response (UnTrans repr) =>
269 repr (ResponseArgs repr a)
270 (Response repr)
271 response' = noTrans (response' @_ @a)
272
273 response ::
274 forall a repr.
275 CLI_Response repr =>
276 ResponseConstraint repr a =>
277 repr (ResponseArgs repr a)
278 (Response repr)
279 response = response' @repr @a
280 {-# INLINE response #-}
281
282 -- * Class 'CLI_Help'
283 class CLI_Help repr where
284 type HelpConstraint repr d :: Constraint
285 help :: HelpConstraint repr d => d -> repr f k -> repr f k
286 help _msg = id
287 program :: Name -> repr f k -> repr f k
288 rule :: Name -> repr f k -> repr f k
289 -- Trans defaults
290 type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
291 default program ::
292 Trans repr =>
293 CLI_Help (UnTrans repr) =>
294 Name -> repr f k -> repr f k
295 default rule ::
296 Trans repr =>
297 CLI_Help (UnTrans repr) =>
298 Name -> repr f k -> repr f k
299 program n = noTrans . program n . unTrans
300 rule n = noTrans . rule n . unTrans
301 infixr 0 `help`
302
303 -- * Type 'Trans'
304 class Trans repr where
305 -- | The @(repr)@esentation that @(repr)@ 'Trans'forms.
306 type UnTrans repr :: * -> * -> *
307 -- | Lift the underlying @(repr)@esentation to @(repr)@.
308 -- Useful to define a combinator that does nothing in a 'Trans'formation.
309 noTrans :: UnTrans repr a b -> repr a b
310 -- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
311 -- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
312 -- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
313 -- from the inferred @(repr)@ value (eg. in 'server').
314 unTrans :: repr a b -> UnTrans repr a b