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