{-# 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