src/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