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(..), fromJust)
14 import Data.String (String, IsString(..))
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 alt :: repr a k -> repr a k -> repr a k
32 opt :: repr (a->k) k -> repr (Maybe a->k) k
37 repr a k -> repr b k -> repr (a:!:b) k
41 repr a k -> repr a k -> repr a k
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.
55 -- | Like @(,)@ but @infixr@.
56 data (:!:) a b = a:!:b
61 dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
66 (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
67 dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
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
76 AltApp (UnTrans repr) =>
77 repr (a->k) k -> repr ([a]->k) k
80 AltApp (UnTrans repr) =>
81 repr (a->k) k -> repr ([a]->k) k
82 many0 = noTrans . many0 . unTrans
83 many1 = noTrans . many1 . unTrans
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
94 -- | Convenient wrapper to omit a 'runPermutation'.
97 -- opts '<?>' next = 'runPermutation' opts '<.>' next
100 App repr => Permutable repr =>
101 Permutation repr b a -> repr b c -> repr (a->b) c
102 opts <?> next = runPermutation opts <.> next
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
117 type Segment = String
119 -- * Class 'CLI_Command'
120 class CLI_Command repr where
121 command :: Name -> repr a k -> repr a k
124 class CLI_Var repr where
125 type VarConstraint repr a :: Constraint
126 var' :: VarConstraint repr a => Name -> repr (a->k) k
127 just :: a -> repr (a->k) k
130 type VarConstraint repr a = VarConstraint (UnTrans repr) a
133 CLI_Var (UnTrans repr) =>
134 VarConstraint (UnTrans repr) a =>
135 Name -> repr (a->k) k
138 CLI_Var (UnTrans repr) =>
142 CLI_Var (UnTrans repr) =>
144 var' = noTrans . var'
145 just = noTrans . just
146 nothing = noTrans nothing
148 -- | Like 'var'' but with the type variable @(a)@ first instead or @(repr)@
149 -- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
153 VarConstraint repr a =>
154 Name -> repr (a->k) k
159 class CLI_Env repr where
160 type EnvConstraint repr a :: Constraint
161 env' :: EnvConstraint repr a => Name -> repr (a->k) k
163 type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
166 CLI_Env (UnTrans repr) =>
167 EnvConstraint (UnTrans repr) a =>
168 Name -> repr (a->k) k
169 env' = noTrans . env'
171 -- | Like 'env'' but with the type enviable @(a)@ first instead or @(repr)@
172 -- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
176 EnvConstraint repr a =>
177 Name -> repr (a->k) k
187 instance IsString Tag where
194 class (App repr, Permutable repr, CLI_Var repr) => CLI_Tag repr where
195 type TagConstraint repr a :: Constraint
196 tag :: Tag -> repr f k -> repr f k
197 -- tag n = (tag n <.>)
200 flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
201 flag n = toPermDefault False $ tag n $ just True
204 TagConstraint repr a => AltApp repr => Alt repr => Pro repr =>
205 Tag -> repr (a->k) k -> Permutation repr k (Maybe a)
206 optionalTag n = toPermDefault Nothing . tag n . dimap Just fromJust
209 TagConstraint repr a =>
210 Tag -> a -> repr (a->k) k -> Permutation repr k a
211 defaultTag n a = toPermDefault a . tag n
214 TagConstraint repr a =>
215 Tag -> repr (a->k) k -> Permutation repr k a
216 requiredTag n = toPermutation . tag n
219 TagConstraint repr a => AltApp repr =>
220 Tag -> repr (a->k) k -> Permutation repr k [a]
221 many0Tag n = toPermDefault [] . many1 . tag n
223 TagConstraint repr a => AltApp repr =>
224 Tag -> repr (a->k) k -> Permutation repr k [a]
225 many1Tag n = toPermutation . many1 . tag n
228 type TagConstraint repr a = TagConstraint (UnTrans repr) a
231 CLI_Tag (UnTrans repr) =>
232 Tag -> repr f k -> repr f k
235 CLI_Tag (UnTrans repr) =>
237 tag n = noTrans . tag n . unTrans
238 endOpts = noTrans endOpts
240 -- * Class 'CLI_Response'
241 class CLI_Response repr where
242 type ResponseConstraint repr a :: Constraint
243 type ResponseArgs repr a :: * -- = (r:: *) | r -> a
244 type Response repr :: *
246 ResponseConstraint repr a =>
247 repr (ResponseArgs repr a)
250 type ResponseConstraint repr a = ResponseConstraint (UnTrans repr) a
251 type ResponseArgs repr a = ResponseArgs (UnTrans repr) a
252 type Response repr = Response (UnTrans repr)
256 CLI_Response (UnTrans repr) =>
257 ResponseConstraint (UnTrans repr) a =>
258 ResponseArgs repr a ~ ResponseArgs (UnTrans repr) a =>
259 Response repr ~ Response (UnTrans repr) =>
260 repr (ResponseArgs repr a)
262 response' = noTrans (response' @_ @a)
267 ResponseConstraint repr a =>
268 repr (ResponseArgs repr a)
270 response = response' @repr @a
271 {-# INLINE response #-}
273 -- * Class 'CLI_Help'
274 class CLI_Help repr where
275 type HelpConstraint repr d :: Constraint
276 help :: HelpConstraint repr d => d -> repr f k -> repr f k
278 program :: Name -> repr f k -> repr f k
279 rule :: Name -> repr f k -> repr f k
281 type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
284 CLI_Help (UnTrans repr) =>
285 Name -> repr f k -> repr f k
288 CLI_Help (UnTrans repr) =>
289 Name -> repr f k -> repr f k
290 program n = noTrans . program n . unTrans
291 rule n = noTrans . rule n . unTrans
295 class Trans repr where
296 -- | The @(repr)@esentation that @(repr)@ 'Trans'forms.
297 type UnTrans repr :: * -> * -> *
298 -- | Lift the underlying @(repr)@esentation to @(repr)@.
299 -- Useful to define a combinator that does nothing in a 'Trans'formation.
300 noTrans :: UnTrans repr a b -> repr a b
301 -- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
302 -- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
303 -- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
304 -- from the inferred @(repr)@ value (eg. in 'server').
305 unTrans :: repr a b -> UnTrans repr a b