1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE Rank2Types #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
6 module Symantic.CLI.Schema where
8 import Control.Applicative (Applicative(..))
10 import Data.Char (Char)
11 import Data.Function (($), (.), id)
12 import Data.Functor (Functor(..), (<$>))
13 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
14 import Data.Monoid (Monoid(..))
15 import Data.Semigroup (Semigroup(..))
16 import Data.String (String, IsString(..))
17 import Data.Text (Text)
18 import Text.Show (Show(..))
19 import qualified Data.List as List
20 import qualified Data.Text.Lazy as TL
21 import qualified Data.Text.Lazy.Builder as TLB
22 import qualified Symantic.Document as Doc
24 import Symantic.CLI.API
25 import Symantic.CLI.Fixity
29 = Schema { unSchema :: SchemaInh d -> Maybe d }
31 runSchema :: Monoid d => Schema d f k -> SchemaInh d -> d
32 runSchema (Schema s) = fromMaybe mempty . s
34 docSchema :: Monoid d => SchemaDoc d => Schema d f k -> d
35 docSchema s = runSchema s defSchemaInh
37 coerceSchema :: Schema d f k -> Schema d f' k'
38 coerceSchema Schema{..} = Schema{..}
40 -- ** Class 'SchemaDoc'
50 , Doc.From (Doc.Word Char) d
51 , Doc.From (Doc.Word Text) d
52 , Doc.From (Doc.Word String) d
55 -- ** Type 'SchemaInh'
56 -- | Inherited top-down.
59 { schemaInh_op :: (Infix, Side) -- ^ Parent operator.
60 , schemaInh_define :: Bool -- ^ Whether to print a definition, or not.
61 , schemaInh_or :: d -- ^ The separator to use between alternatives.
64 defSchemaInh :: SchemaDoc d => SchemaInh d
65 defSchemaInh = SchemaInh
66 { schemaInh_op = (infixN0, SideL)
67 , schemaInh_define = True
68 , schemaInh_or = docOrH
71 pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d
72 pairIfNeeded opInh op =
73 if needsParenInfix opInh op
74 then Doc.align . Doc.parens
77 instance Semigroup d => Semigroup (Schema d f k) where
78 Schema x <> Schema y = Schema $ x <> y
79 instance (Semigroup d, Monoid d) => Monoid (Schema d f k) where
80 mempty = Schema mempty
82 instance (Semigroup d, IsString d) => IsString (Schema d f k) where
83 fromString "" = Schema $ \_inh -> Nothing
84 fromString s = Schema $ \_inh -> Just $ fromString s
85 instance Show (Schema (Doc.Plain TLB.Builder) a k) where
92 docOrH, docOrV :: Doc.Spaceable d => Doc.From (Doc.Word Char) d => d
93 docOrH = Doc.space <> Doc.from (Doc.Word '|') <> Doc.space
94 docOrV = Doc.newline <> Doc.from (Doc.Word '|') <> Doc.space
97 instance SchemaDoc d => Functor (Schema d f) where
98 _f `fmap` Schema x = Schema $ \inh ->
99 pairIfNeeded (schemaInh_op inh) op <$>
100 x inh{schemaInh_op=(op, SideR)}
104 instance SchemaDoc d => App (Schema d) where
105 Schema f <.> Schema x = Schema $ \inh ->
106 case f inh{schemaInh_op=(op, SideL)} of
107 Nothing -> x inh{schemaInh_op=(op, SideR)}
109 case x inh{schemaInh_op=(op, SideR)} of
112 pairIfNeeded (schemaInh_op inh) op $
113 fd <> Doc.space <> xd
116 instance SchemaDoc d => Alt (Schema d) where
117 l <!> r = Schema $ \inh ->
118 -- NOTE: first try to see if both sides are 'Just',
119 -- otherwise does not change the inherited operator context.
120 case (unSchema l inh, unSchema r inh) of
121 (Nothing, Nothing) -> Nothing
122 (Just ld, Nothing) -> Just ld
123 (Nothing, Just rd) -> Just rd
124 (Just{}, Just{}) -> Just $
125 if needsParenInfix (schemaInh_op inh) op
127 -- NOTE: when parenthesis are needed
128 -- first try to fit the alternative on a single line,
129 -- otherwise align them on multiple lines.
132 -- Doc.withBreakable Nothing $
134 { schemaInh_op=(op, SideL)
135 , schemaInh_or=docOrH } <>
138 { schemaInh_op=(op, SideR)
139 , schemaInh_or=docOrH })
144 { schemaInh_op=(op, SideL)
145 , schemaInh_or=docOrV } <>
148 { schemaInh_op=(op, SideR)
149 , schemaInh_or=docOrV } <>
152 -- NOTE: when parenthesis are NOT needed
153 -- just concat alternatives using the inherited separator
154 -- (either horizontal or vertical).
155 runSchema l inh{schemaInh_op=(op, SideL)} <>
157 runSchema r inh{schemaInh_op=(op, SideR)}
158 where op = infixB SideL 2
159 alt x y = coerceSchema $ coerceSchema x <!> coerceSchema y
160 opt s = Schema $ \inh -> Just $
162 runSchema s inh{schemaInh_op=(op, SideL)}
164 instance SchemaDoc d => Sequenceable (Schema d) where
165 type Sequence (Schema d) = SchemaSeq d
166 runSequence (SchemaSeq fin ps) =
168 [] -> fin $ Schema $ \_inh -> Nothing
169 _ -> fin $ Schema $ \inh -> Just $
170 pairIfNeeded (schemaInh_op inh) op $
171 Doc.intercalate Doc.breakspace $
172 catMaybes $ (<$> ps) $ \(Schema s) ->
174 { schemaInh_op=(op, SideL)
175 , schemaInh_or=docOrH }
177 toSequence = SchemaSeq id . pure
178 instance SchemaDoc d => Permutable (Schema d) where
179 type Permutation (Schema d) = SchemaPerm d
180 runPermutation (SchemaPerm fin ps) =
182 [] -> fin $ Schema $ \_inh -> Nothing
183 _ -> fin $ Schema $ \inh -> Just $
184 pairIfNeeded (schemaInh_op inh) op $
185 Doc.intercalate Doc.breakspace $
186 catMaybes $ (<$> ps) $ \(Schema s) ->
188 { schemaInh_op=(op, SideL)
189 , schemaInh_or=docOrH }
191 toPermutation = SchemaPerm id . pure
192 toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $
193 if needsParenInfix (schemaInh_op inh) op
196 runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}
198 runSchema s inh{schemaInh_op=(op, SideL)}
200 instance Pro (Schema d) where
201 dimap _a2b _b2a = coerceSchema
202 instance SchemaDoc d => AltApp (Schema d) where
203 many0 s = Schema $ \inh -> Just $
204 pairIfNeeded (schemaInh_op inh) op $
205 runSchema s inh{schemaInh_op=(op, SideL)}<>"*"
207 many1 s = Schema $ \inh -> Just $
208 pairIfNeeded (schemaInh_op inh) op $
209 runSchema s inh{schemaInh_op=(op, SideL)}<>"+"
211 instance SchemaDoc d => CLI_Command (Schema d) where
212 -- type CommandConstraint (Schema d) a = ()
213 command n s = Schema $ \inh -> Just $
214 if schemaInh_define inh || List.null n
218 (fromString n <.> coerceSchema s)
219 inh{schemaInh_define = False}
226 Doc.from (Doc.Word n)
227 instance SchemaDoc d => CLI_Var (Schema d) where
228 type VarConstraint (Schema d) a = ()
229 var' n = Schema $ \_inh -> Just $
230 Doc.underline $ Doc.from $ Doc.Word n
231 instance SchemaDoc d => CLI_Constant (Schema d) where
232 constant c _a = Schema $ \_inh -> Just $
233 Doc.from (Doc.Word c)
234 just _ = Schema $ \_inh -> Nothing
235 nothing = Schema $ \_inh -> Nothing
236 instance SchemaDoc d => CLI_Env (Schema d) where
237 type EnvConstraint (Schema d) a = ()
238 env' _n = Schema $ \_inh -> Nothing
239 -- NOTE: environment variables are not shown in the schema,
241 instance SchemaDoc d => CLI_Tag (Schema d) where
242 type TagConstraint (Schema d) a = ()
243 tag n r = Schema $ \inh ->
244 unSchema (prefix n <.> r) inh
247 Tag s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
248 TagShort s -> fromString ['-', s]
249 TagLong l -> fromString ("--"<>l)
250 endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
251 instance SchemaDoc d => CLI_Help (Schema d) where
252 type HelpConstraint (Schema d) d' = d ~ d'
254 program n s = Schema $ \inh -> Just $
256 (fromString n <.> coerceSchema s)
257 inh{schemaInh_define = False}
258 rule n s = Schema $ \inh -> Just $
259 if schemaInh_define inh
260 then runSchema s inh{schemaInh_define=False}
267 Doc.from (Doc.Word n)
268 data SchemaResponseArgs a
269 instance SchemaDoc d => CLI_Response (Schema d) where
270 type ResponseConstraint (Schema d) a = ()
271 type ResponseArgs (Schema d) a = SchemaResponseArgs a
272 type Response (Schema d) = ()
273 response' = Schema $ \_inh -> Nothing
275 -- ** Type 'SchemaSeq'
276 data SchemaSeq d k a = SchemaSeq
277 { schemaSeq_finalizer :: forall b c.
280 -- ^ Used to implement 'rule'.
281 , schemaSeq_alternatives :: [Schema d (a->k) k]
282 -- ^ Collect alternatives for rendering them all at once in 'runSequence'.
284 instance Functor (SchemaSeq d k) where
285 _f`fmap`SchemaSeq fin ps = SchemaSeq fin (coerceSchema <$> ps)
286 instance Applicative (SchemaSeq d k) where
287 pure _a = SchemaSeq id mempty
288 SchemaSeq fd f <*> SchemaSeq fx x =
289 SchemaSeq (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
290 instance SchemaDoc d => CLI_Help (SchemaSeq d) where
291 type HelpConstraint (SchemaSeq d) d' = d ~ d'
293 program n (SchemaSeq fin ps) = SchemaSeq (program n . fin) ps
294 rule n (SchemaSeq fin ps) = SchemaSeq (rule n . fin) ps
296 -- ** Type 'SchemaPerm'
297 data SchemaPerm d k a = SchemaPerm
298 { schemaPerm_finalizer :: forall b c.
301 -- ^ Used to implement 'rule'.
302 , schemaPerm_alternatives :: [Schema d (a->k) k]
303 -- ^ Collect alternatives for rendering them all at once in 'runPermutation'.
305 instance Functor (SchemaPerm d k) where
306 _f`fmap`SchemaPerm fin ps = SchemaPerm fin (coerceSchema <$> ps)
307 instance Applicative (SchemaPerm d k) where
308 pure _a = SchemaPerm id mempty
309 SchemaPerm fd f <*> SchemaPerm fx x =
310 SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
311 instance SchemaDoc d => CLI_Help (SchemaPerm d) where
312 type HelpConstraint (SchemaPerm d) d' = d ~ d'
314 program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps
315 rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps