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