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