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