{-# LANGUAGE TypeFamilyDependencies #-}
module Language.Symantic.CLI.Sym where

import Data.Bool
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq)
import Data.Function (($), (.), const, id)
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..), catMaybes)
import Data.Ord (Ord(..))
import Data.String (String)
import Text.Show (Show)

-- * @Arg@ types
-- | Types to type the symantics:
-- eg. to segregate options from commands.
data ArgCommand
data ArgOption
data ArgValue
data ArgRule t

-- * Type 'Name'
type Name = String

-- * Class 'Sym_Fun'
class Sym_Fun repr where
        (<$$>) :: (a -> b) -> repr e t a -> repr e t b
        (<$$)  :: a -> repr e t b -> repr e t a
        (<$$) = (<$$>) . const
        ($$>)  :: repr e t b -> a -> repr e t a
        r $$> a = const a <$$> r
-- * Class 'Sym_App'
class Sym_Fun repr => Sym_App repr where
        value     :: a -> repr e ArgValue a
        (<**>)    :: repr e t (a -> b) -> repr e u a -> repr e u b
        (**>)     :: repr e t a -> repr e u b -> repr e u b
        a **> b = id <$$ a <**> b
        (<**)     :: repr e t a -> repr e u b -> repr e u a
        a <** b = const <$$> a <**> b
        end       :: repr e t ()
-- * Class 'Sym_Alt'
class Sym_Fun repr => Sym_Alt repr where
        (<||>)    :: repr e t a -> repr e t a -> repr e t a
        choice    :: [repr e t a] -> repr e t a
        optional  :: repr e t a -> repr e t (Maybe a)
        optional a = option Nothing (Just <$$> a)
        option    :: a -> repr e t a -> repr e t a
        try       :: repr e t a -> repr e t a
-- * Class 'Sym_AltApp'
class (Sym_Alt repr, Sym_App repr) => Sym_AltApp repr where
        many      :: repr e t a -> repr e t [a]
        some      :: repr e t a -> repr e t [a]
        -- default intermany :: (Sym_Alt repr, Sym_App repr) => [repr e t a] -> repr e t [a]
        intermany :: [repr e t a] -> repr e t [a]
        intermany = many . choice . (try <$>)
-- * Class 'Sym_Interleaved'
class Sym_Interleaved repr where
        interleaved :: Perm (repr e t) a -> repr e t a
        (<<$>>)  :: (a -> b) -> repr e t a -> Perm (repr e t) b
        (<<$?>>) :: (a -> b) -> (a, repr e t a) -> Perm (repr e t) b
        (<<$*>>) :: ([a] -> b) -> repr e t a -> Perm (repr e t) b
        (<<|>>)  :: Perm (repr e t) (a -> b) -> repr e t a -> Perm (repr e t) b
        (<<|?>>) :: Perm (repr e t) (a -> b) -> (a, repr e t a) -> Perm (repr e t) b
        (<<|*>>) :: Perm (repr e t) ([a] -> b) -> repr e t a -> Perm (repr e t) b

        (<<$) :: a -> repr e t b -> Perm (repr e t) a
        (<<$) = (<<$>>) . const
        (<<$?) :: a -> (b, repr e t b) -> Perm (repr e t) a
        a <<$? b = const a <<$?>> b
        {- NOTE: cannot be done without and instance:
	 - Functor (P.PermParser s m)
	(<<|)  :: Functor (Perm (repr e t)) => Perm (repr e t) a -> repr e t b -> Perm (repr e t) a
	(<<|?) :: Functor (Perm (repr e t)) => Perm (repr e t) a -> (b, repr e t b) -> Perm (repr e t) a
	a <<|  b = (const <$> a) <<|>> b
	a <<|? b = (const <$> a) <<|?>> b
	-}
infixl 4 <$$>
infixl 4 <**>
infixl 3 <||>
infixl 2 <<$>>, <<$?>>, <<$*>>
infixl 1 <<|>>, <<|?>>, <<|*>>
-- ** Type family 'Perm'
type family Perm (repr:: * -> *) = (r :: * -> *) | r -> repr
-- * Class 'Sym_Rule'
class Sym_Rule repr where
        rule :: String -> repr e t a -> repr e t a
        -- rule _n = id
-- * Class 'Sym_Command'
class Sym_Command repr where
        main       :: Name -> repr e t a -> repr e ArgCommand a
        command    :: Name -> repr e t a -> repr e ArgCommand a
-- * Class 'Sym_Option'
class Sym_AltApp repr => Sym_Option repr where
        opt    :: OptionName -> repr e s a -> repr e ArgOption a
        var    :: Name -> (String -> Either e a) -> repr e ArgValue a
        tag    :: String -> repr e ArgValue ()
        -- int    :: repr e ArgValue Int

        long   :: Name -> repr e ArgValue a -> repr e ArgOption a
        short  :: Char -> repr e ArgValue a -> repr e ArgOption a
        flag   :: OptionName -> (Bool, repr e ArgOption Bool)
        endOpt :: repr e ArgOption ()
        string :: Name -> repr e ArgValue String
        long   = opt . OptionNameLong
        short  = opt . OptionNameShort
        flag n = (False,) $ opt n $ value True
        endOpt = option () $ opt (OptionNameLong "") $ value ()
        string n = var n Right
-- ** Type 'OptionName'
data OptionName
 =   OptionName Char Name
 |   OptionNameLong Name
 |   OptionNameShort Char
 deriving (Eq, Show)
instance Ord OptionName where
        x`compare`y =
                catMaybes [longOf x, shortOf x]
                `compare`
                catMaybes [longOf y, shortOf y]
                where
                longOf = \case
                 OptionName _s l -> Just l
                 OptionNameLong l -> Just l
                 OptionNameShort _s -> Nothing
                shortOf = \case
                 OptionName s _l -> Just [s]
                 OptionNameLong _l -> Nothing
                 OptionNameShort s -> Just [s]
-- * Class 'Sym_Help'
class Sym_Help d repr where
        help :: d -> repr e t a -> repr e t a
-- * Class 'Sym_Exit'
class Sym_Exit repr where
        exit :: e -> repr e t ()