symantic-cli/Language/Symantic/CLI/Sym.hs

   1 {-# LANGUAGE TypeFamilyDependencies #-}
   2 module Language.Symantic.CLI.Sym where
   3
   4 import Data.Bool
   5 import Data.Char (Char)
   6 import Data.Either (Either(..))
   7 import Data.Eq (Eq)
   8 import Data.Function (($), (.), const, id)
   9 import Data.Functor ((<$>))
  10 import Data.Maybe (Maybe(..), catMaybes)
  11 import Data.Ord (Ord(..))
  12 import Data.String (String)
  13 import Text.Show (Show)
  14
  15 -- * @Arg@ types
  16 -- | Types to type the symantics:
  17 -- eg. to segregate options from commands.
  18 data ArgCommand
  19 data ArgOption
  20 data ArgValue
  21 data ArgRule t
  22
  23 -- * Type 'Name'
  24 type Name = String
  25
  26 -- * Class 'Sym_Fun'
  27 class Sym_Fun repr where
  28         (<$$>) :: (a -> b) -> repr e t a -> repr e t b
  29         (<$$)  :: a -> repr e t b -> repr e t a
  30         (<$$) = (<$$>) . const
  31         ($$>)  :: repr e t b -> a -> repr e t a
  32         r $$> a = const a <$$> r
  33 -- * Class 'Sym_App'
  34 class Sym_Fun repr => Sym_App repr where
  35         value     :: a -> repr e ArgValue a
  36         (<**>)    :: repr e t (a -> b) -> repr e u a -> repr e u b
  37         (**>)     :: repr e t a -> repr e u b -> repr e u b
  38         a **> b = id <$$ a <**> b
  39         (<**)     :: repr e t a -> repr e u b -> repr e u a
  40         a <** b = const <$$> a <**> b
  41         end       :: repr e t ()
  42 -- * Class 'Sym_Alt'
  43 class Sym_Fun repr => Sym_Alt repr where
  44         (<||>)    :: repr e t a -> repr e t a -> repr e t a
  45         choice    :: [repr e t a] -> repr e t a
  46         optional  :: repr e t a -> repr e t (Maybe a)
  47         optional a = option Nothing (Just <$$> a)
  48         option    :: a -> repr e t a -> repr e t a
  49         try       :: repr e t a -> repr e t a
  50 -- * Class 'Sym_AltApp'
  51 class (Sym_Alt repr, Sym_App repr) => Sym_AltApp repr where
  52         many      :: repr e t a -> repr e t [a]
  53         some      :: repr e t a -> repr e t [a]
  54         -- default intermany :: (Sym_Alt repr, Sym_App repr) => [repr e t a] -> repr e t [a]
  55         intermany :: [repr e t a] -> repr e t [a]
  56         intermany = many . choice . (try <$>)
  57 -- * Class 'Sym_Interleaved'
  58 class Sym_Interleaved repr where
  59         interleaved :: Perm (repr e t) a -> repr e t a
  60         (<<$>>)  :: (a -> b) -> repr e t a -> Perm (repr e t) b
  61         (<<$?>>) :: (a -> b) -> (a, repr e t a) -> Perm (repr e t) b
  62         (<<$*>>) :: ([a] -> b) -> repr e t a -> Perm (repr e t) b
  63         (<<|>>)  :: Perm (repr e t) (a -> b) -> repr e t a -> Perm (repr e t) b
  64         (<<|?>>) :: Perm (repr e t) (a -> b) -> (a, repr e t a) -> Perm (repr e t) b
  65         (<<|*>>) :: Perm (repr e t) ([a] -> b) -> repr e t a -> Perm (repr e t) b
  66
  67         (<<$) :: a -> repr e t b -> Perm (repr e t) a
  68         (<<$) = (<<$>>) . const
  69         (<<$?) :: a -> (b, repr e t b) -> Perm (repr e t) a
  70         a <<$? b = const a <<$?>> b
  71         {- NOTE: cannot be done without and instance:
  72          - Functor (P.PermParser s m)
  73         (<<|)  :: Functor (Perm (repr e t)) => Perm (repr e t) a -> repr e t b -> Perm (repr e t) a
  74         (<<|?) :: Functor (Perm (repr e t)) => Perm (repr e t) a -> (b, repr e t b) -> Perm (repr e t) a
  75         a <<|  b = (const <$> a) <<|>> b
  76         a <<|? b = (const <$> a) <<|?>> b
  77         -}
  78 infixl 4 <$$>
  79 infixl 4 <**>
  80 infixl 3 <||>
  81 infixl 2 <<$>>, <<$?>>, <<$*>>
  82 infixl 1 <<|>>, <<|?>>, <<|*>>
  83 -- ** Type family 'Perm'
  84 type family Perm (repr:: * -> *) = (r :: * -> *) | r -> repr
  85 -- * Class 'Sym_Rule'
  86 class Sym_Rule repr where
  87         rule :: String -> repr e t a -> repr e t a
  88         -- rule _n = id
  89 -- * Class 'Sym_Command'
  90 class Sym_Command repr where
  91         main       :: Name -> repr e t a -> repr e ArgCommand a
  92         command    :: Name -> repr e t a -> repr e ArgCommand a
  93 -- * Class 'Sym_Option'
  94 class Sym_AltApp repr => Sym_Option repr where
  95         opt    :: OptionName -> repr e s a -> repr e ArgOption a
  96         var    :: Name -> (String -> Either e a) -> repr e ArgValue a
  97         tag    :: String -> repr e ArgValue ()
  98         -- int    :: repr e ArgValue Int
  99
 100         long   :: Name -> repr e ArgValue a -> repr e ArgOption a
 101         short  :: Char -> repr e ArgValue a -> repr e ArgOption a
 102         flag   :: OptionName -> (Bool, repr e ArgOption Bool)
 103         endOpt :: repr e ArgOption ()
 104         string :: Name -> repr e ArgValue String
 105         long   = opt . OptionNameLong
 106         short  = opt . OptionNameShort
 107         flag n = (False,) $ opt n $ value True
 108         endOpt = option () $ opt (OptionNameLong "") $ value ()
 109         string n = var n Right
 110 -- ** Type 'OptionName'
 111 data OptionName
 112  =   OptionName Char Name
 113  |   OptionNameLong Name
 114  |   OptionNameShort Char
 115  deriving (Eq, Show)
 116 instance Ord OptionName where
 117         x`compare`y =
 118                 catMaybes [longOf x, shortOf x]
 119                 `compare`
 120                 catMaybes [longOf y, shortOf y]
 121                 where
 122                 longOf = \case
 123                  OptionName _s l -> Just l
 124                  OptionNameLong l -> Just l
 125                  OptionNameShort _s -> Nothing
 126                 shortOf = \case
 127                  OptionName s _l -> Just [s]
 128                  OptionNameLong _l -> Nothing
 129                  OptionNameShort s -> Just [s]
 130 -- * Class 'Sym_Help'
 131 class Sym_Help d repr where
 132         help :: d -> repr e t a -> repr e t a
 133 -- * Class 'Sym_Exit'
 134 class Sym_Exit repr where
 135         exit :: e -> repr e t ()