symantic-cli-2.0.0.20190615: Symantic/CLI/API.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-} -- for type instance defaults
module Symantic.CLI.API where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq)
import Data.Function (($), (.), id)
import Data.Int (Int)
import Data.Kind (Constraint)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid)
import Data.String (String)
import Data.Text (Text)
import Text.Show (Show)
import Data.Functor (Functor(..), (<$>))

-- * Class 'App'
class App repr where
	(<.>) :: repr a b -> repr b c -> repr a c
	-- Trans defaults
	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'
class Alt repr where
	(<!>) :: repr a k -> repr b k -> repr (a:!:b) k
	-- Trans defaults
	default (<!>) ::
	 Trans repr =>
	 Alt (UnTrans repr) =>
	 repr a k -> repr b k -> repr (a:!:b) k
	x <!> y = noTrans (unTrans x <!> unTrans y)
	opt :: repr (a->k) k -> repr (Maybe a->k) k
infixr 3 <!>

-- ** Type (':!:')
-- | Like @(,)@ but @infixr@.
data (:!:) a b = a:!:b
infixr 3 :!:

-- * Class 'Pro'
class Pro repr where
	dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
	-- Trans defaults
	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'
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'
class Permutable repr where
	-- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
	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

-- | Convenient wrapper to omit a 'runPermutation'.
--
-- @
-- opts '<?>' next = 'runPermutation' opts '<.>' next
-- @
(<?>) ::
 App repr => Permutable repr =>
 Permutation repr b a -> repr b c -> repr (a->b) c
opts <?> next = runPermutation opts <.> next
infixr 4 <?>

-- * Type 'Name'
type Name = String

-- * Type 'Segment'
type Segment = String

-- * Class 'CLI_Command'
class CLI_Command repr where
	command :: Name -> repr a k -> repr a k

-- * Class 'CLI_Var'
class CLI_Var repr where
	type VarConstraint repr a :: Constraint
	var' :: VarConstraint repr a => Name -> repr (a->k) k
	just :: a -> repr (a->k) k
	nothing :: repr k k
	-- Trans defaults
	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
	default just ::
	 Trans repr =>
	 CLI_Var (UnTrans repr) =>
	 a -> repr (a->k) k
	default nothing ::
	 Trans repr =>
	 CLI_Var (UnTrans repr) =>
	 repr k k
	var'    = noTrans . var'
	just    = noTrans . just
	nothing = noTrans nothing

-- | Like 'var'' but with the type variable @(a)@ first instead or @(repr)@
-- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
var ::
 forall a k repr.
 CLI_Var repr =>
 VarConstraint repr a =>
 Name -> repr (a->k) k
var = var'
{-# INLINE var #-}

-- * Class 'CLI_Env'
class CLI_Env repr where
	type EnvConstraint repr a :: Constraint
	env' :: EnvConstraint repr a => Name -> repr (a->k) k
	-- Trans defaults
	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'

-- | Like 'env'' but with the type enviable @(a)@ first instead or @(repr)@
-- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
env ::
 forall a k repr.
 CLI_Env repr =>
 EnvConstraint repr a =>
 Name -> repr (a->k) k
env = env'
{-# INLINE env #-}

-- ** Type 'Tag'
data Tag
 =   Tag Char Name
 |   TagLong Name
 |   TagShort Char
 deriving (Eq, Show)

-- * Class 'CLI_Tag'
class (App repr, Permutable repr, CLI_Var repr) => CLI_Tag repr where
	type TagConstraint repr a :: Constraint
	tagged :: Tag -> repr f k -> repr f k
	endOpts :: repr k k
	
	-- tagged n = (tag n <.>)
	short :: TagConstraint repr a => Char -> repr (a->k) k -> Permutation repr k a
	short n = toPermutation . tagged (TagShort n)
	long :: TagConstraint repr a => Name -> repr (a->k) k -> Permutation repr k a
	long n = toPermutation . tagged (TagLong n)
	
	option :: TagConstraint repr a => a -> repr (a->k) k -> Permutation repr k a
	option = toPermDefault
	flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
	flag n = toPermDefault False $ tagged n $ just True
	shortOpt :: TagConstraint repr a => Char -> a -> repr (a->k) k -> Permutation repr k a
	shortOpt n a = toPermDefault a . tagged (TagShort n)
	longOpt :: TagConstraint repr a => Name -> a -> repr (a->k) k -> Permutation repr k a
	longOpt n a = toPermDefault a . tagged (TagLong n)
	
	-- Trans defaults
	type TagConstraint repr a = TagConstraint (UnTrans repr) a
	default tagged ::
	 Trans repr =>
	 CLI_Tag (UnTrans repr) =>
	 Tag -> repr f k -> repr f k
	default endOpts ::
	 Trans repr =>
	 CLI_Tag (UnTrans repr) =>
	 repr k k
	tagged n = noTrans . tagged n . unTrans
	endOpts = noTrans endOpts

-- * Class 'CLI_Response'
class CLI_Response repr where
	type ResponseConstraint repr a :: Constraint
	type ResponseArgs repr a :: * -- = (r:: *) | r -> a
	type Response repr :: *
	response' ::
	 ResponseConstraint repr a =>
	 repr (ResponseArgs repr a)
	      (Response repr)
	-- Trans defaults
	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'
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
	-- Trans defaults
	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`

-- * Type 'Trans'
class Trans repr where
	-- | The @(repr)@esentation that @(repr)@ 'Trans'forms.
	type UnTrans repr :: * -> * -> *
	-- | Lift the underlying @(repr)@esentation to @(repr)@.
	-- Useful to define a combinator that does nothing in a 'Trans'formation.
	noTrans :: UnTrans repr a b -> repr a b
	-- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
	-- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
	-- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
	-- from the inferred @(repr)@ value (eg. in 'server').
	unTrans :: repr a b -> UnTrans repr a b