{-# 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)
import Data.Sequence (Seq)

-- * @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
	infixl 4 <$$>, <$$, $$>
-- * 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 ()
	infixl 4 <**>, <**, **>
-- * Class 'Sym_Alt'
class Sym_Fun repr => Sym_Alt repr where
	(<||>)    :: repr e t a -> repr e t a -> repr e t a
	infixl 3 <||>
	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_Permutation'
class Sym_Permutation repr where
	runPermutation :: Permutation (repr e t) a -> repr e t a
	toPermutation :: repr e t a -> Permutation (repr e t) a
	toPermutationWithDefault :: a -> repr e t a -> Permutation (repr e t) a
	
	-- NOTE: QuantifiedConstraints on Permutation may help to get rid of these operators.
	(<<$>>)  :: (a -> b) -> repr e t a -> Permutation (repr e t) b
	(<<$)    :: a -> repr e t b -> Permutation (repr e t) a
	(<<$?>>) :: (a -> b) -> (a, repr e t a) -> Permutation (repr e t) b
	(<<$?)   :: a -> (b, repr e t b) -> Permutation (repr e t) a
	(<<$*>>) :: Sym_AltApp repr => ([a] -> b) -> repr e t a -> Permutation (repr e t) b
	(<<$:>>) :: Sym_AltApp repr => (Seq a -> b) -> repr e t a -> Permutation (repr e t) b
	infixl 2 <<$>>, <<$, <<$?>>, <<$?, <<$*>>, <<$:>>
	
	(<<|>>)  :: Permutation (repr e t) (a -> b) -> repr e t a -> Permutation (repr e t) b
	(<<|)    :: Permutation (repr e t) a -> repr e t b -> Permutation (repr e t) a
	(<<|?>>) :: Permutation (repr e t) (a -> b) -> (a, repr e t a) -> Permutation (repr e t) b
	(<<|?)   :: Permutation (repr e t) a -> (b, repr e t b) -> Permutation (repr e t) a
	(<<|*>>) :: Permutation (repr e t) ([a] -> b) -> repr e t a -> Permutation (repr e t) b
	(<<|:>>) :: Permutation (repr e t) (Seq a -> b) -> repr e t a -> Permutation (repr e t) b
	infixl 1 <<|>>, <<|, <<|?>>, <<|?, <<|*>>, <<|:>>
-- ** Type family 'Permutation'
-- | Type of permutations, depending on the representation.
type family Permutation (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 ()