]> Git — Sourcephile - haskell/symantic.git/blob - symantic-cli/Language/Symantic/CLI/Sym.hs
Support GHC-8.4.3.
[haskell/symantic.git] / 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 ()