]> Git — Sourcephile - haskell/symantic-cli.git/blob - Symantic/CLI/API.hs
parser: drop newtype wrapping of ParserResponseArgs
[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(..))
14 import Data.String (String)
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 opt :: repr (a->k) k -> repr (Maybe a->k) k
32 -- Trans defaults
33 default (<!>) ::
34 Trans repr =>
35 Alt (UnTrans repr) =>
36 repr a k -> repr b k -> repr (a:!:b) k
37 x <!> y = noTrans (unTrans x <!> unTrans y)
38 default opt ::
39 Trans repr =>
40 Alt (UnTrans repr) =>
41 repr (a->k) k -> repr (Maybe a->k) k
42 opt = noTrans . opt . unTrans
43 infixr 3 <!>
44
45 -- ** Type (':!:')
46 -- | Like @(,)@ but @infixr@.
47 data (:!:) a b = a:!:b
48 infixr 3 :!:
49
50 -- * Class 'Pro'
51 class Pro repr where
52 dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
53 -- Trans defaults
54 default dimap ::
55 Trans repr =>
56 Pro (UnTrans repr) =>
57 (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
58 dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
59
60 -- * Class 'AltApp'
61 class AltApp repr where
62 many0 :: repr (a->k) k -> repr ([a]->k) k
63 many1 :: repr (a->k) k -> repr ([a]->k) k
64 default many0 ::
65 Trans repr =>
66 AltApp (UnTrans repr) =>
67 repr (a->k) k -> repr ([a]->k) k
68 default many1 ::
69 Trans repr =>
70 AltApp (UnTrans repr) =>
71 repr (a->k) k -> repr ([a]->k) k
72 many0 = noTrans . many0 . unTrans
73 many1 = noTrans . many1 . unTrans
74
75 -- * Class 'Permutable'
76 class Permutable repr where
77 -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
78 type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
79 type Permutation repr = Permutation (UnTrans repr)
80 runPermutation :: Permutation repr k a -> repr (a->k) k
81 toPermutation :: repr (a->k) k -> Permutation repr k a
82 toPermDefault :: a -> repr (a->k) k -> Permutation repr k a
83
84 -- | Convenient wrapper to omit a 'runPermutation'.
85 --
86 -- @
87 -- opts '<?>' next = 'runPermutation' opts '<.>' next
88 -- @
89 (<?>) ::
90 App repr => Permutable repr =>
91 Permutation repr b a -> repr b c -> repr (a->b) c
92 opts <?> next = runPermutation opts <.> next
93 infixr 4 <?>
94
95 -- * Type 'Name'
96 type Name = String
97
98 -- * Type 'Segment'
99 type Segment = String
100
101 -- * Class 'CLI_Command'
102 class CLI_Command repr where
103 command :: Name -> repr a k -> repr a k
104
105 -- * Class 'CLI_Var'
106 class CLI_Var repr where
107 type VarConstraint repr a :: Constraint
108 var' :: VarConstraint repr a => Name -> repr (a->k) k
109 just :: a -> repr (a->k) k
110 nothing :: repr k k
111 -- Trans defaults
112 type VarConstraint repr a = VarConstraint (UnTrans repr) a
113 default var' ::
114 Trans repr =>
115 CLI_Var (UnTrans repr) =>
116 VarConstraint (UnTrans repr) a =>
117 Name -> repr (a->k) k
118 default just ::
119 Trans repr =>
120 CLI_Var (UnTrans repr) =>
121 a -> repr (a->k) k
122 default nothing ::
123 Trans repr =>
124 CLI_Var (UnTrans repr) =>
125 repr k k
126 var' = noTrans . var'
127 just = noTrans . just
128 nothing = noTrans nothing
129
130 -- | Like 'var'' but with the type variable @(a)@ first instead or @(repr)@
131 -- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
132 var ::
133 forall a k repr.
134 CLI_Var repr =>
135 VarConstraint repr a =>
136 Name -> repr (a->k) k
137 var = var'
138 {-# INLINE var #-}
139
140 -- * Class 'CLI_Env'
141 class CLI_Env repr where
142 type EnvConstraint repr a :: Constraint
143 env' :: EnvConstraint repr a => Name -> repr (a->k) k
144 -- Trans defaults
145 type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
146 default env' ::
147 Trans repr =>
148 CLI_Env (UnTrans repr) =>
149 EnvConstraint (UnTrans repr) a =>
150 Name -> repr (a->k) k
151 env' = noTrans . env'
152
153 -- | Like 'env'' but with the type enviable @(a)@ first instead or @(repr)@
154 -- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
155 env ::
156 forall a k repr.
157 CLI_Env repr =>
158 EnvConstraint repr a =>
159 Name -> repr (a->k) k
160 env = env'
161 {-# INLINE env #-}
162
163 -- ** Type 'Tag'
164 data Tag
165 = Tag Char Name
166 | TagLong Name
167 | TagShort Char
168 deriving (Eq, Show)
169
170 -- * Class 'CLI_Tag'
171 class (App repr, Permutable repr, CLI_Var repr) => CLI_Tag repr where
172 type TagConstraint repr a :: Constraint
173 tagged :: Tag -> repr f k -> repr f k
174 endOpts :: repr k k
175
176 -- tagged n = (tag n <.>)
177 short :: TagConstraint repr a => Char -> repr (a->k) k -> Permutation repr k a
178 short n = toPermutation . tagged (TagShort n)
179 long :: TagConstraint repr a => Name -> repr (a->k) k -> Permutation repr k a
180 long n = toPermutation . tagged (TagLong n)
181
182 option :: TagConstraint repr a => a -> repr (a->k) k -> Permutation repr k a
183 option = toPermDefault
184 flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
185 flag n = toPermDefault False $ tagged n $ just True
186 shortOpt :: TagConstraint repr a => Char -> a -> repr (a->k) k -> Permutation repr k a
187 shortOpt n a = toPermDefault a . tagged (TagShort n)
188 longOpt :: TagConstraint repr a => Name -> a -> repr (a->k) k -> Permutation repr k a
189 longOpt n a = toPermDefault a . tagged (TagLong n)
190
191 -- Trans defaults
192 type TagConstraint repr a = TagConstraint (UnTrans repr) a
193 default tagged ::
194 Trans repr =>
195 CLI_Tag (UnTrans repr) =>
196 Tag -> repr f k -> repr f k
197 default endOpts ::
198 Trans repr =>
199 CLI_Tag (UnTrans repr) =>
200 repr k k
201 tagged n = noTrans . tagged n . unTrans
202 endOpts = noTrans endOpts
203
204 -- * Class 'CLI_Response'
205 class CLI_Response repr where
206 type ResponseConstraint repr a :: Constraint
207 type ResponseArgs repr a :: * -- = (r:: *) | r -> a
208 type Response repr :: *
209 response' ::
210 ResponseConstraint repr a =>
211 repr (ResponseArgs repr a)
212 (Response repr)
213 -- Trans defaults
214 type ResponseConstraint repr a = ResponseConstraint (UnTrans repr) a
215 type ResponseArgs repr a = ResponseArgs (UnTrans repr) a
216 type Response repr = Response (UnTrans repr)
217 default response' ::
218 forall a.
219 Trans repr =>
220 CLI_Response (UnTrans repr) =>
221 ResponseConstraint (UnTrans repr) a =>
222 ResponseArgs repr a ~ ResponseArgs (UnTrans repr) a =>
223 Response repr ~ Response (UnTrans repr) =>
224 repr (ResponseArgs repr a)
225 (Response repr)
226 response' = noTrans (response' @_ @a)
227
228 response ::
229 forall a repr.
230 CLI_Response repr =>
231 ResponseConstraint repr a =>
232 repr (ResponseArgs repr a)
233 (Response repr)
234 response = response' @repr @a
235 {-# INLINE response #-}
236
237 -- * Class 'CLI_Help'
238 class CLI_Help repr where
239 type HelpConstraint repr d :: Constraint
240 help :: HelpConstraint repr d => d -> repr f k -> repr f k
241 help _msg = id
242 program :: Name -> repr f k -> repr f k
243 rule :: Name -> repr f k -> repr f k
244 -- Trans defaults
245 type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
246 default program ::
247 Trans repr =>
248 CLI_Help (UnTrans repr) =>
249 Name -> repr f k -> repr f k
250 default rule ::
251 Trans repr =>
252 CLI_Help (UnTrans repr) =>
253 Name -> repr f k -> repr f k
254 program n = noTrans . program n . unTrans
255 rule n = noTrans . rule n . unTrans
256 infixr 0 `help`
257
258 -- * Type 'Trans'
259 class Trans repr where
260 -- | The @(repr)@esentation that @(repr)@ 'Trans'forms.
261 type UnTrans repr :: * -> * -> *
262 -- | Lift the underlying @(repr)@esentation to @(repr)@.
263 -- Useful to define a combinator that does nothing in a 'Trans'formation.
264 noTrans :: UnTrans repr a b -> repr a b
265 -- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
266 -- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
267 -- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
268 -- from the inferred @(repr)@ value (eg. in 'server').
269 unTrans :: repr a b -> UnTrans repr a b