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         just :: a -> repr (a->k) k
 128         nothing :: repr k k
 129         -- Trans defaults
 130         type VarConstraint repr a = VarConstraint (UnTrans repr) a
 131         default var' ::
 132          Trans repr =>
 133          CLI_Var (UnTrans repr) =>
 134          VarConstraint (UnTrans repr) a =>
 135          Name -> repr (a->k) k
 136         default just ::
 137          Trans repr =>
 138          CLI_Var (UnTrans repr) =>
 139          a -> repr (a->k) k
 140         default nothing ::
 141          Trans repr =>
 142          CLI_Var (UnTrans repr) =>
 143          repr k k
 144         var'    = noTrans . var'
 145         just    = noTrans . just
 146         nothing = noTrans nothing
 147
 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)@.
 150 var ::
 151  forall a k repr.
 152  CLI_Var repr =>
 153  VarConstraint repr a =>
 154  Name -> repr (a->k) k
 155 var = var'
 156 {-# INLINE var #-}
 157
 158 -- * Class 'CLI_Env'
 159 class CLI_Env repr where
 160         type EnvConstraint repr a :: Constraint
 161         env' :: EnvConstraint repr a => Name -> repr (a->k) k
 162         -- Trans defaults
 163         type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
 164         default env' ::
 165          Trans repr =>
 166          CLI_Env (UnTrans repr) =>
 167          EnvConstraint (UnTrans repr) a =>
 168          Name -> repr (a->k) k
 169         env' = noTrans . env'
 170
 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)@.
 173 env ::
 174  forall a k repr.
 175  CLI_Env repr =>
 176  EnvConstraint repr a =>
 177  Name -> repr (a->k) k
 178 env = env'
 179 {-# INLINE env #-}
 180
 181 -- ** Type 'Tag'
 182 data Tag
 183  =   Tag Char Name
 184  |   TagLong Name
 185  |   TagShort Char
 186  deriving (Eq, Show)
 187 instance IsString Tag where
 188         fromString = \case
 189          [c] -> TagShort c
 190          c:'|':cs -> Tag c cs
 191          cs -> TagLong cs
 192
 193 -- * Class 'CLI_Tag'
 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 <.>)
 198         endOpts :: repr k k
 199
 200         flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
 201         flag n = toPermDefault False $ tag n $ just True
 202
 203         optionalTag ::
 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
 207
 208         defaultTag ::
 209          TagConstraint repr a =>
 210          Tag -> a -> repr (a->k) k -> Permutation repr k a
 211         defaultTag n a = toPermDefault a . tag n
 212
 213         requiredTag ::
 214          TagConstraint repr a =>
 215          Tag -> repr (a->k) k -> Permutation repr k a
 216         requiredTag n = toPermutation . tag n
 217
 218         many0Tag ::
 219          TagConstraint repr a => AltApp repr =>
 220          Tag -> repr (a->k) k -> Permutation repr k [a]
 221         many0Tag n = toPermDefault [] . many1 . tag n
 222         many1Tag ::
 223          TagConstraint repr a => AltApp repr =>
 224          Tag -> repr (a->k) k -> Permutation repr k [a]
 225         many1Tag n = toPermutation . many1 . tag n
 226
 227         -- Trans defaults
 228         type TagConstraint repr a = TagConstraint (UnTrans repr) a
 229         default tag ::
 230          Trans repr =>
 231          CLI_Tag (UnTrans repr) =>
 232          Tag -> repr f k -> repr f k
 233         default endOpts ::
 234          Trans repr =>
 235          CLI_Tag (UnTrans repr) =>
 236          repr k k
 237         tag n = noTrans . tag n . unTrans
 238         endOpts = noTrans endOpts
 239
 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 :: *
 245         response' ::
 246          ResponseConstraint repr a =>
 247          repr (ResponseArgs repr a)
 248               (Response repr)
 249         -- Trans defaults
 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)
 253         default response' ::
 254          forall a.
 255          Trans 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)
 261               (Response repr)
 262         response' = noTrans (response' @_ @a)
 263
 264 response ::
 265  forall a repr.
 266  CLI_Response repr =>
 267  ResponseConstraint repr a =>
 268  repr (ResponseArgs repr a)
 269       (Response repr)
 270 response = response' @repr @a
 271 {-# INLINE response #-}
 272
 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
 277         help _msg = id
 278         program :: Name -> repr f k -> repr f k
 279         rule :: Name -> repr f k -> repr f k
 280         -- Trans defaults
 281         type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
 282         default program ::
 283          Trans repr =>
 284          CLI_Help (UnTrans repr) =>
 285          Name -> repr f k -> repr f k
 286         default rule ::
 287          Trans repr =>
 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
 292 infixr 0 `help`
 293
 294 -- * Type 'Trans'
 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