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