Sym.hs

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