{-# 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)
data ArgCommand
data ArgOption
data ArgValue
data ArgRule t
type Name = String
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_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_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_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]
intermany :: [repr e t a] -> repr e t [a]
intermany = many . choice . (try <$>)
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
infixl 4 <$$>
infixl 4 <**>
infixl 3 <||>
infixl 2 <<$>>, <<$?>>, <<$*>>
infixl 1 <<|>>, <<|?>>, <<|*>>
type family Perm (repr:: * -> *) = (r :: * -> *) | r -> repr
class Sym_Rule repr where
rule :: String -> repr e t a -> repr e t a
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_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 ()
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
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 d repr where
help :: d -> repr e t a -> repr e t a
class Sym_Exit repr where
exit :: e -> repr e t ()