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
9 import Data.Char (Char)
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)
19 (<.>) :: repr a b -> repr b c -> repr a c
24 repr a b -> repr b c -> repr a c
25 x <.> y = noTrans (unTrans x <.> unTrans y)
30 (<!>) :: repr a k -> repr b k -> repr (a:!:b) k
31 opt :: repr (a->k) k -> repr (Maybe a->k) k
36 repr a k -> repr b k -> repr (a:!:b) k
37 x <!> y = noTrans (unTrans x <!> unTrans y)
41 repr (a->k) k -> repr (Maybe a->k) k
42 opt = noTrans . opt . unTrans
46 -- | Like @(,)@ but @infixr@.
47 data (:!:) a b = a:!:b
52 dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
57 (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
58 dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
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
66 AltApp (UnTrans repr) =>
67 repr (a->k) k -> repr ([a]->k) k
70 AltApp (UnTrans repr) =>
71 repr (a->k) k -> repr ([a]->k) k
72 many0 = noTrans . many0 . unTrans
73 many1 = noTrans . many1 . unTrans
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
84 -- | Convenient wrapper to omit a 'runPermutation'.
87 -- opts '<?>' next = 'runPermutation' opts '<.>' next
90 App repr => Permutable repr =>
91 Permutation repr b a -> repr b c -> repr (a->b) c
92 opts <?> next = runPermutation opts <.> next
101 -- * Class 'CLI_Command'
102 class CLI_Command repr where
103 command :: Name -> repr a k -> repr a k
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
112 type VarConstraint repr a = VarConstraint (UnTrans repr) a
115 CLI_Var (UnTrans repr) =>
116 VarConstraint (UnTrans repr) a =>
117 Name -> repr (a->k) k
120 CLI_Var (UnTrans repr) =>
124 CLI_Var (UnTrans repr) =>
126 var' = noTrans . var'
127 just = noTrans . just
128 nothing = noTrans nothing
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)@.
135 VarConstraint repr a =>
136 Name -> repr (a->k) k
141 class CLI_Env repr where
142 type EnvConstraint repr a :: Constraint
143 env' :: EnvConstraint repr a => Name -> repr (a->k) k
145 type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
148 CLI_Env (UnTrans repr) =>
149 EnvConstraint (UnTrans repr) a =>
150 Name -> repr (a->k) k
151 env' = noTrans . env'
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)@.
158 EnvConstraint repr a =>
159 Name -> repr (a->k) k
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
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)
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)
192 type TagConstraint repr a = TagConstraint (UnTrans repr) a
195 CLI_Tag (UnTrans repr) =>
196 Tag -> repr f k -> repr f k
199 CLI_Tag (UnTrans repr) =>
201 tagged n = noTrans . tagged n . unTrans
202 endOpts = noTrans endOpts
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 :: *
210 ResponseConstraint repr a =>
211 repr (ResponseArgs repr a)
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)
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)
226 response' = noTrans (response' @_ @a)
231 ResponseConstraint repr a =>
232 repr (ResponseArgs repr a)
234 response = response' @repr @a
235 {-# INLINE response #-}
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
242 program :: Name -> repr f k -> repr f k
243 rule :: Name -> repr f k -> repr f k
245 type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
248 CLI_Help (UnTrans repr) =>
249 Name -> repr f k -> repr f k
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
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