{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-} -- for type instance defaults
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'
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
	alt :: repr a k -> repr a k -> repr a k
	opt :: repr (a->k) k -> repr (Maybe a->k) k
	-- Trans defaults
	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
-- NOTE: yes infixr, not infixl like <|>,
-- in order to run left-most checks first.
infixr 3 <!>
infixr 3 `alt`

-- ** 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
	-- Trans defaults
	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
	-- NOTE: 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 <?>

-- * Class 'Sequenceable'
class Sequenceable repr where
	-- NOTE: Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
	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'
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
	-- 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
	var' = noTrans . var'

-- | 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_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'
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)
instance IsString Tag where
	fromString = \case
	 [c] -> TagShort c
	 c:'|':cs -> Tag c cs
	 cs -> TagLong cs

-- * Class 'CLI_Tag'
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
	-- tag n = (tag n <.>)
	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
	
	-- Trans defaults
	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'
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