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         opt :: repr (a->k) k -> repr (Maybe a->k) k
  32         -- Trans defaults
  33         default (<!>) ::
  34          Trans repr =>
  35          Alt (UnTrans repr) =>
  36          repr a k -> repr b k -> repr (a:!:b) k
  37         x <!> y = noTrans (unTrans x <!> unTrans y)
  38         default opt ::
  39          Trans repr =>
  40          Alt (UnTrans repr) =>
  41          repr (a->k) k -> repr (Maybe a->k) k
  42         opt = noTrans . opt . unTrans
  43 infixr 3 <!>
  44
  45 -- ** Type (':!:')
  46 -- | Like @(,)@ but @infixr@.
  47 data (:!:) a b = a:!:b
  48 infixr 3 :!:
  49
  50 -- * Class 'Pro'
  51 class Pro repr where
  52         dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
  53         -- Trans defaults
  54         default dimap ::
  55          Trans repr =>
  56          Pro (UnTrans repr) =>
  57          (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
  58         dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
  59
  60 -- * Class 'AltApp'
  61 class AltApp repr where
  62         many0 :: repr (a->k) k -> repr ([a]->k) k
  63         many1 :: repr (a->k) k -> repr ([a]->k) k
  64         default many0 ::
  65          Trans repr =>
  66          AltApp (UnTrans repr) =>
  67          repr (a->k) k -> repr ([a]->k) k
  68         default many1 ::
  69          Trans repr =>
  70          AltApp (UnTrans repr) =>
  71          repr (a->k) k -> repr ([a]->k) k
  72         many0   = noTrans . many0 . unTrans
  73         many1   = noTrans . many1 . unTrans
  74
  75 -- * Class 'Permutable'
  76 class Permutable repr where
  77         -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
  78         type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
  79         type Permutation repr = Permutation (UnTrans repr)
  80         runPermutation :: Permutation repr k a -> repr (a->k) k
  81         toPermutation :: repr (a->k) k -> Permutation repr k a
  82         toPermDefault :: a -> repr (a->k) k -> Permutation repr k a
  83
  84 -- | Convenient wrapper to omit a 'runPermutation'.
  85 --
  86 -- @
  87 -- opts '<?>' next = 'runPermutation' opts '<.>' next
  88 -- @
  89 (<?>) ::
  90  App repr => Permutable repr =>
  91  Permutation repr b a -> repr b c -> repr (a->b) c
  92 opts <?> next = runPermutation opts <.> next
  93 infixr 4 <?>
  94
  95 -- * Type 'Name'
  96 type Name = String
  97
  98 -- * Type 'Segment'
  99 type Segment = String
 100
 101 -- * Class 'CLI_Command'
 102 class CLI_Command repr where
 103         command :: Name -> repr a k -> repr a k
 104
 105 -- * Class 'CLI_Var'
 106 class CLI_Var repr where
 107         type VarConstraint repr a :: Constraint
 108         var' :: VarConstraint repr a => Name -> repr (a->k) k
 109         just :: a -> repr (a->k) k
 110         nothing :: repr k k
 111         -- Trans defaults
 112         type VarConstraint repr a = VarConstraint (UnTrans repr) a
 113         default var' ::
 114          Trans repr =>
 115          CLI_Var (UnTrans repr) =>
 116          VarConstraint (UnTrans repr) a =>
 117          Name -> repr (a->k) k
 118         default just ::
 119          Trans repr =>
 120          CLI_Var (UnTrans repr) =>
 121          a -> repr (a->k) k
 122         default nothing ::
 123          Trans repr =>
 124          CLI_Var (UnTrans repr) =>
 125          repr k k
 126         var'    = noTrans . var'
 127         just    = noTrans . just
 128         nothing = noTrans nothing
 129
 130 -- | Like 'var'' but with the type variable @(a)@ first instead or @(repr)@
 131 -- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
 132 var ::
 133  forall a k repr.
 134  CLI_Var repr =>
 135  VarConstraint repr a =>
 136  Name -> repr (a->k) k
 137 var = var'
 138 {-# INLINE var #-}
 139
 140 -- * Class 'CLI_Env'
 141 class CLI_Env repr where
 142         type EnvConstraint repr a :: Constraint
 143         env' :: EnvConstraint repr a => Name -> repr (a->k) k
 144         -- Trans defaults
 145         type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
 146         default env' ::
 147          Trans repr =>
 148          CLI_Env (UnTrans repr) =>
 149          EnvConstraint (UnTrans repr) a =>
 150          Name -> repr (a->k) k
 151         env' = noTrans . env'
 152
 153 -- | Like 'env'' but with the type enviable @(a)@ first instead or @(repr)@
 154 -- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
 155 env ::
 156  forall a k repr.
 157  CLI_Env repr =>
 158  EnvConstraint repr a =>
 159  Name -> repr (a->k) k
 160 env = env'
 161 {-# INLINE env #-}
 162
 163 -- ** Type 'Tag'
 164 data Tag
 165  =   Tag Char Name
 166  |   TagLong Name
 167  |   TagShort Char
 168  deriving (Eq, Show)
 169
 170 -- * Class 'CLI_Tag'
 171 class (App repr, Permutable repr, CLI_Var repr) => CLI_Tag repr where
 172         type TagConstraint repr a :: Constraint
 173         tagged :: Tag -> repr f k -> repr f k
 174         endOpts :: repr k k
 175
 176         -- tagged n = (tag n <.>)
 177         short :: TagConstraint repr a => Char -> repr (a->k) k -> Permutation repr k a
 178         short n = toPermutation . tagged (TagShort n)
 179         long :: TagConstraint repr a => Name -> repr (a->k) k -> Permutation repr k a
 180         long n = toPermutation . tagged (TagLong n)
 181
 182         option :: TagConstraint repr a => a -> repr (a->k) k -> Permutation repr k a
 183         option = toPermDefault
 184         flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
 185         flag n = toPermDefault False $ tagged n $ just True
 186         shortOpt :: TagConstraint repr a => Char -> a -> repr (a->k) k -> Permutation repr k a
 187         shortOpt n a = toPermDefault a . tagged (TagShort n)
 188         longOpt :: TagConstraint repr a => Name -> a -> repr (a->k) k -> Permutation repr k a
 189         longOpt n a = toPermDefault a . tagged (TagLong n)
 190
 191         -- Trans defaults
 192         type TagConstraint repr a = TagConstraint (UnTrans repr) a
 193         default tagged ::
 194          Trans repr =>
 195          CLI_Tag (UnTrans repr) =>
 196          Tag -> repr f k -> repr f k
 197         default endOpts ::
 198          Trans repr =>
 199          CLI_Tag (UnTrans repr) =>
 200          repr k k
 201         tagged n = noTrans . tagged n . unTrans
 202         endOpts = noTrans endOpts
 203
 204 -- * Class 'CLI_Response'
 205 class CLI_Response repr where
 206         type ResponseConstraint repr a :: Constraint
 207         type ResponseArgs repr a :: * -- = (r:: *) | r -> a
 208         type Response repr :: *
 209         response' ::
 210          ResponseConstraint repr a =>
 211          repr (ResponseArgs repr a)
 212               (Response repr)
 213         -- Trans defaults
 214         type ResponseConstraint repr a = ResponseConstraint (UnTrans repr) a
 215         type ResponseArgs repr a = ResponseArgs (UnTrans repr) a
 216         type Response repr = Response (UnTrans repr)
 217         default response' ::
 218          forall a.
 219          Trans repr =>
 220          CLI_Response (UnTrans repr) =>
 221          ResponseConstraint (UnTrans repr) a =>
 222          ResponseArgs repr a ~ ResponseArgs (UnTrans repr) a =>
 223          Response repr ~ Response (UnTrans repr) =>
 224          repr (ResponseArgs repr a)
 225               (Response repr)
 226         response' = noTrans (response' @_ @a)
 227
 228 response ::
 229  forall a repr.
 230  CLI_Response repr =>
 231  ResponseConstraint repr a =>
 232  repr (ResponseArgs repr a)
 233       (Response repr)
 234 response = response' @repr @a
 235 {-# INLINE response #-}
 236
 237 -- * Class 'CLI_Help'
 238 class CLI_Help repr where
 239         type HelpConstraint repr d :: Constraint
 240         help :: HelpConstraint repr d => d -> repr f k -> repr f k
 241         help _msg = id
 242         program :: Name -> repr f k -> repr f k
 243         rule :: Name -> repr f k -> repr f k
 244         -- Trans defaults
 245         type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
 246         default program ::
 247          Trans repr =>
 248          CLI_Help (UnTrans repr) =>
 249          Name -> repr f k -> repr f k
 250         default rule ::
 251          Trans repr =>
 252          CLI_Help (UnTrans repr) =>
 253          Name -> repr f k -> repr f k
 254         program n = noTrans . program n . unTrans
 255         rule n = noTrans . rule n . unTrans
 256 infixr 0 `help`
 257
 258 -- * Type 'Trans'
 259 class Trans repr where
 260         -- | The @(repr)@esentation that @(repr)@ 'Trans'forms.
 261         type UnTrans repr :: * -> * -> *
 262         -- | Lift the underlying @(repr)@esentation to @(repr)@.
 263         -- Useful to define a combinator that does nothing in a 'Trans'formation.
 264         noTrans :: UnTrans repr a b -> repr a b
 265         -- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
 266         -- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
 267         -- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
 268         -- from the inferred @(repr)@ value (eg. in 'server').
 269         unTrans :: repr a b -> UnTrans repr a b