{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.CLI.API where
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq)
import Data.Function (($), (.), id)
import Data.Kind (Constraint)
import Data.Maybe (Maybe(..), fromJust)
import Data.String (String, IsString(..))
import Text.Show (Show)
class App repr where
(<.>) :: repr a b -> repr b c -> repr a c
default (<.>) ::
Trans repr =>
App (UnTrans repr) =>
repr a b -> repr b c -> repr a c
x <.> y = noTrans (unTrans x <.> unTrans y)
infixr 4 <.>
class Alt repr where
(<!>) :: repr a k -> repr b k -> repr (a:!:b) k
alt :: repr a k -> repr a k -> repr a k
opt :: repr (a->k) k -> repr (Maybe a->k) k
default (<!>) ::
Trans repr =>
Alt (UnTrans repr) =>
repr a k -> repr b k -> repr (a:!:b) k
default alt ::
Trans repr =>
Alt (UnTrans repr) =>
repr a k -> repr a k -> repr a k
default opt ::
Trans repr =>
Alt (UnTrans repr) =>
repr (a->k) k -> repr (Maybe a->k) k
x <!> y = noTrans (unTrans x <!> unTrans y)
x `alt` y = noTrans (unTrans x `alt` unTrans y)
opt = noTrans . opt . unTrans
infixr 3 <!>
infixr 3 `alt`
data (:!:) a b = a:!:b
infixr 3 :!:
class Pro repr where
dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
default dimap ::
Trans repr =>
Pro (UnTrans repr) =>
(a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
class AltApp repr where
many0 :: repr (a->k) k -> repr ([a]->k) k
many1 :: repr (a->k) k -> repr ([a]->k) k
default many0 ::
Trans repr =>
AltApp (UnTrans repr) =>
repr (a->k) k -> repr ([a]->k) k
default many1 ::
Trans repr =>
AltApp (UnTrans repr) =>
repr (a->k) k -> repr ([a]->k) k
many0 = noTrans . many0 . unTrans
many1 = noTrans . many1 . unTrans
class Permutable repr where
type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
type Permutation repr = Permutation (UnTrans repr)
runPermutation :: Permutation repr k a -> repr (a->k) k
toPermutation :: repr (a->k) k -> Permutation repr k a
toPermDefault :: a -> repr (a->k) k -> Permutation repr k a
(<?>) ::
App repr => Permutable repr =>
Permutation repr b a -> repr b c -> repr (a->b) c
opts <?> next = runPermutation opts <.> next
infixr 4 <?>
class Sequenceable repr where
type Sequence (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
type Sequence repr = Sequence (UnTrans repr)
runSequence :: Sequence repr k a -> repr (a->k) k
toSequence :: repr (a->k) k -> Sequence repr k a
type Name = String
type Segment = String
class CLI_Command repr where
command :: Name -> repr a k -> repr a k
class CLI_Var repr where
type VarConstraint repr a :: Constraint
var' :: VarConstraint repr a => Name -> repr (a->k) k
type VarConstraint repr a = VarConstraint (UnTrans repr) a
default var' ::
Trans repr =>
CLI_Var (UnTrans repr) =>
VarConstraint (UnTrans repr) a =>
Name -> repr (a->k) k
var' = noTrans . var'
var ::
forall a k repr.
CLI_Var repr =>
VarConstraint repr a =>
Name -> repr (a->k) k
var = var'
{-# INLINE var #-}
class CLI_Constant repr where
constant :: Segment -> a -> repr (a->k) k
just :: a -> repr (a->k) k
nothing :: repr k k
default constant ::
Trans repr =>
CLI_Constant (UnTrans repr) =>
Segment -> a -> repr (a->k) k
default just ::
Trans repr =>
CLI_Constant (UnTrans repr) =>
a -> repr (a->k) k
default nothing ::
Trans repr =>
CLI_Constant (UnTrans repr) =>
repr k k
constant s = noTrans . constant s
just = noTrans . just
nothing = noTrans nothing
class CLI_Env repr where
type EnvConstraint repr a :: Constraint
env' :: EnvConstraint repr a => Name -> repr (a->k) k
type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
default env' ::
Trans repr =>
CLI_Env (UnTrans repr) =>
EnvConstraint (UnTrans repr) a =>
Name -> repr (a->k) k
env' = noTrans . env'
env ::
forall a k repr.
CLI_Env repr =>
EnvConstraint repr a =>
Name -> repr (a->k) k
env = env'
{-# INLINE env #-}
data Tag
= Tag Char Name
| TagLong Name
| TagShort Char
deriving (Eq, Show)
instance IsString Tag where
fromString = \case
[c] -> TagShort c
c:'|':cs -> Tag c cs
cs -> TagLong cs
class (App repr, Permutable repr, CLI_Constant repr) => CLI_Tag repr where
type TagConstraint repr a :: Constraint
tag :: Tag -> repr f k -> repr f k
endOpts :: repr k k
flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
flag n = toPermDefault False $ tag n $ just True
optionalTag ::
TagConstraint repr a => AltApp repr => Alt repr => Pro repr =>
Tag -> repr (a->k) k -> Permutation repr k (Maybe a)
optionalTag n = toPermDefault Nothing . tag n . dimap Just fromJust
defaultTag ::
TagConstraint repr a =>
Tag -> a -> repr (a->k) k -> Permutation repr k a
defaultTag n a = toPermDefault a . tag n
requiredTag ::
TagConstraint repr a =>
Tag -> repr (a->k) k -> Permutation repr k a
requiredTag n = toPermutation . tag n
many0Tag ::
TagConstraint repr a => AltApp repr =>
Tag -> repr (a->k) k -> Permutation repr k [a]
many0Tag n = toPermDefault [] . many1 . tag n
many1Tag ::
TagConstraint repr a => AltApp repr =>
Tag -> repr (a->k) k -> Permutation repr k [a]
many1Tag n = toPermutation . many1 . tag n
type TagConstraint repr a = TagConstraint (UnTrans repr) a
default tag ::
Trans repr =>
CLI_Tag (UnTrans repr) =>
Tag -> repr f k -> repr f k
default endOpts ::
Trans repr =>
CLI_Tag (UnTrans repr) =>
repr k k
tag n = noTrans . tag n . unTrans
endOpts = noTrans endOpts
class CLI_Response repr where
type ResponseConstraint repr a :: Constraint
type ResponseArgs repr a :: *
type Response repr :: *
response' ::
ResponseConstraint repr a =>
repr (ResponseArgs repr a)
(Response repr)
type ResponseConstraint repr a = ResponseConstraint (UnTrans repr) a
type ResponseArgs repr a = ResponseArgs (UnTrans repr) a
type Response repr = Response (UnTrans repr)
default response' ::
forall a.
Trans repr =>
CLI_Response (UnTrans repr) =>
ResponseConstraint (UnTrans repr) a =>
ResponseArgs repr a ~ ResponseArgs (UnTrans repr) a =>
Response repr ~ Response (UnTrans repr) =>
repr (ResponseArgs repr a)
(Response repr)
response' = noTrans (response' @_ @a)
response ::
forall a repr.
CLI_Response repr =>
ResponseConstraint repr a =>
repr (ResponseArgs repr a)
(Response repr)
response = response' @repr @a
{-# INLINE response #-}
class CLI_Help repr where
type HelpConstraint repr d :: Constraint
help :: HelpConstraint repr d => d -> repr f k -> repr f k
help _msg = id
program :: Name -> repr f k -> repr f k
rule :: Name -> repr f k -> repr f k
type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
default program ::
Trans repr =>
CLI_Help (UnTrans repr) =>
Name -> repr f k -> repr f k
default rule ::
Trans repr =>
CLI_Help (UnTrans repr) =>
Name -> repr f k -> repr f k
program n = noTrans . program n . unTrans
rule n = noTrans . rule n . unTrans
infixr 0 `help`
class Trans repr where
type UnTrans repr :: * -> * -> *
noTrans :: UnTrans repr a b -> repr a b
unTrans :: repr a b -> UnTrans repr a b