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(..))
  14 import Data.String (String)
  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
 188 -- * Class 'CLI_Tag'
 189 class (App repr, Permutable repr, CLI_Var repr) => CLI_Tag repr where
 190         type TagConstraint repr a :: Constraint
 191         tagged :: Tag -> repr f k -> repr f k
 192         endOpts :: repr k k
 193
 194         -- tagged n = (tag n <.>)
 195         short :: TagConstraint repr a => Char -> repr (a->k) k -> Permutation repr k a
 196         short n = toPermutation . tagged (TagShort n)
 197         long :: TagConstraint repr a => Name -> repr (a->k) k -> Permutation repr k a
 198         long n = toPermutation . tagged (TagLong n)
 199
 200         option :: TagConstraint repr a => a -> repr (a->k) k -> Permutation repr k a
 201         option = toPermDefault
 202         flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
 203         flag n = toPermDefault False $ tagged n $ just True
 204         shortOpt :: TagConstraint repr a => Char -> a -> repr (a->k) k -> Permutation repr k a
 205         shortOpt n a = toPermDefault a . tagged (TagShort n)
 206         longOpt :: TagConstraint repr a => Name -> a -> repr (a->k) k -> Permutation repr k a
 207         longOpt n a = toPermDefault a . tagged (TagLong n)
 208
 209         -- Trans defaults
 210         type TagConstraint repr a = TagConstraint (UnTrans repr) a
 211         default tagged ::
 212          Trans repr =>
 213          CLI_Tag (UnTrans repr) =>
 214          Tag -> repr f k -> repr f k
 215         default endOpts ::
 216          Trans repr =>
 217          CLI_Tag (UnTrans repr) =>
 218          repr k k
 219         tagged n = noTrans . tagged n . unTrans
 220         endOpts = noTrans endOpts
 221
 222 -- * Class 'CLI_Response'
 223 class CLI_Response repr where
 224         type ResponseConstraint repr a :: Constraint
 225         type ResponseArgs repr a :: * -- = (r:: *) | r -> a
 226         type Response repr :: *
 227         response' ::
 228          ResponseConstraint repr a =>
 229          repr (ResponseArgs repr a)
 230               (Response repr)
 231         -- Trans defaults
 232         type ResponseConstraint repr a = ResponseConstraint (UnTrans repr) a
 233         type ResponseArgs repr a = ResponseArgs (UnTrans repr) a
 234         type Response repr = Response (UnTrans repr)
 235         default response' ::
 236          forall a.
 237          Trans repr =>
 238          CLI_Response (UnTrans repr) =>
 239          ResponseConstraint (UnTrans repr) a =>
 240          ResponseArgs repr a ~ ResponseArgs (UnTrans repr) a =>
 241          Response repr ~ Response (UnTrans repr) =>
 242          repr (ResponseArgs repr a)
 243               (Response repr)
 244         response' = noTrans (response' @_ @a)
 245
 246 response ::
 247  forall a repr.
 248  CLI_Response repr =>
 249  ResponseConstraint repr a =>
 250  repr (ResponseArgs repr a)
 251       (Response repr)
 252 response = response' @repr @a
 253 {-# INLINE response #-}
 254
 255 -- * Class 'CLI_Help'
 256 class CLI_Help repr where
 257         type HelpConstraint repr d :: Constraint
 258         help :: HelpConstraint repr d => d -> repr f k -> repr f k
 259         help _msg = id
 260         program :: Name -> repr f k -> repr f k
 261         rule :: Name -> repr f k -> repr f k
 262         -- Trans defaults
 263         type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
 264         default program ::
 265          Trans repr =>
 266          CLI_Help (UnTrans repr) =>
 267          Name -> repr f k -> repr f k
 268         default rule ::
 269          Trans repr =>
 270          CLI_Help (UnTrans repr) =>
 271          Name -> repr f k -> repr f k
 272         program n = noTrans . program n . unTrans
 273         rule n = noTrans . rule n . unTrans
 274 infixr 0 `help`
 275
 276 -- * Type 'Trans'
 277 class Trans repr where
 278         -- | The @(repr)@esentation that @(repr)@ 'Trans'forms.
 279         type UnTrans repr :: * -> * -> *
 280         -- | Lift the underlying @(repr)@esentation to @(repr)@.
 281         -- Useful to define a combinator that does nothing in a 'Trans'formation.
 282         noTrans :: UnTrans repr a b -> repr a b
 283         -- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
 284         -- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
 285         -- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
 286         -- from the inferred @(repr)@ value (eg. in 'server').
 287         unTrans :: repr a b -> UnTrans repr a b