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{..}
41 type Doc = Doc.AnsiText (Doc.Plain TLB.Builder)
43 -- ** Class 'SchemaDoc'
53 , Doc.From (Doc.Word Char) d
54 , Doc.From (Doc.Word Text) d
55 , Doc.From (Doc.Word String) d
58 -- ** Type 'SchemaInh'
59 -- | Inherited top-down.
62 { schemaInh_op :: (Infix, Side) -- ^ Parent operator.
63 , schemaInh_define :: Bool -- ^ Whether to print a definition, or not.
67 defSchemaInh :: SchemaDoc d => SchemaInh d
68 defSchemaInh = SchemaInh
69 { schemaInh_op = (infixN0, SideL)
70 , schemaInh_define = True
71 , schemaInh_or = docOrH
74 pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d
75 pairIfNeeded opInh op =
76 if needsParenInfix opInh op
77 then Doc.align . Doc.parens
80 instance Semigroup d => Semigroup (Schema d f k) where
81 Schema x <> Schema y = Schema $ x <> y
82 instance (Semigroup d, Monoid d) => Monoid (Schema d f k) where
83 mempty = Schema mempty
85 instance (Semigroup d, IsString d) => IsString (Schema d f k) where
86 fromString "" = Schema $ \_inh -> Nothing
87 fromString s = Schema $ \_inh -> Just $ fromString s
88 instance Show (Schema Doc a k) where
96 docOrH, docOrV :: Doc.Spaceable d => Doc.From (Doc.Word Char) d => d
97 docOrH = Doc.space <> Doc.from (Doc.Word '|') <> Doc.space
98 docOrV = Doc.newline <> Doc.from (Doc.Word '|') <> Doc.space
101 instance SchemaDoc d => Functor (Schema d f) where
102 _f `fmap` Schema x = Schema $ \inh ->
103 pairIfNeeded (schemaInh_op inh) op <$>
104 x inh{schemaInh_op=(op, SideR)}
108 instance SchemaDoc d => App (Schema d) where
109 Schema f <.> Schema x = Schema $ \inh ->
110 case f inh{schemaInh_op=(op, SideL)} of
111 Nothing -> x inh{schemaInh_op=(op, SideR)}
113 case x inh{schemaInh_op=(op, SideR)} of
116 pairIfNeeded (schemaInh_op inh) op $
117 fd <> Doc.space <> xd
120 instance SchemaDoc d => Alt (Schema d) where
121 l <!> r = Schema $ \inh ->
122 -- NOTE: first try to see if both sides are 'Just',
123 -- otherwise does not change the inherited operator context.
124 case (unSchema l inh, unSchema r inh) of
125 (Nothing, Nothing) -> Nothing
126 (Just ld, Nothing) -> Just ld
127 (Nothing, Just rd) -> Just rd
128 (Just{}, Just{}) -> Just $
129 if needsParenInfix (schemaInh_op inh) op
131 -- NOTE: when parenthesis are needed
132 -- first try to fit the alternative on a single line,
133 -- otherwise align them on multiple lines.
136 -- Doc.withBreakable Nothing $
138 { schemaInh_op=(op, SideL)
139 , schemaInh_or=docOrH } <>
142 { schemaInh_op=(op, SideR)
143 , schemaInh_or=docOrH })
148 { schemaInh_op=(op, SideL)
149 , schemaInh_or=docOrV } <>
152 { schemaInh_op=(op, SideR)
153 , schemaInh_or=docOrV } <>
156 -- NOTE: when parenthesis are NOT needed
157 -- just concat alternatives using the inherited separator
158 -- (either horizontal or vertical).
159 runSchema l inh{schemaInh_op=(op, SideL)} <>
161 runSchema r inh{schemaInh_op=(op, SideR)}
162 where op = infixB SideL 2
163 alt x y = coerceSchema $ coerceSchema x <!> coerceSchema y
164 opt s = Schema $ \inh -> Just $
166 runSchema s inh{schemaInh_op=(op, SideL)}
168 instance Pro (Schema d) where
169 dimap _a2b _b2a = coerceSchema
170 instance SchemaDoc d => AltApp (Schema d) where
171 many0 s = Schema $ \inh -> Just $
172 runSchema s inh{schemaInh_op=(op, SideL)}<>"*"
174 many1 s = Schema $ \inh -> Just $
175 runSchema s inh{schemaInh_op=(op, SideL)}<>"+"
177 instance SchemaDoc d => CLI_Command (Schema d) where
178 -- type CommandConstraint (Schema d) a = ()
179 command n s = Schema $ \inh -> Just $
180 if schemaInh_define inh || List.null n
184 (fromString n <.> coerceSchema s)
185 inh{schemaInh_define = False}
192 Doc.from (Doc.Word n)
193 instance SchemaDoc d => CLI_Var (Schema d) where
194 type VarConstraint (Schema d) a = ()
195 var' n = Schema $ \_inh -> Just $
196 Doc.underline $ Doc.from $ Doc.Word n
197 just _ = Schema $ \_inh -> Nothing
198 nothing = Schema $ \_inh -> Nothing
199 instance SchemaDoc d => CLI_Env (Schema d) where
200 type EnvConstraint (Schema d) a = ()
201 env' _n = Schema $ \_inh -> Nothing
202 -- NOTE: environment variables are not shown in the schema,
204 instance SchemaDoc d => CLI_Tag (Schema d) where
205 type TagConstraint (Schema d) a = ()
206 tagged n r = Schema $ \inh ->
207 unSchema (prefix n <.> r) inh
210 Tag s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
211 TagShort s -> fromString ['-', s]
212 TagLong l -> fromString ("--"<>l)
213 endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
214 instance SchemaDoc d => CLI_Help (Schema d) where
215 type HelpConstraint (Schema d) d' = d ~ d'
217 program n s = Schema $ \inh -> Just $
219 (fromString n <.> coerceSchema s)
220 inh{schemaInh_define = False}
221 rule n s = Schema $ \inh -> Just $
222 if schemaInh_define inh
223 then runSchema s inh{schemaInh_define=False}
230 Doc.from (Doc.Word n)
231 data SchemaResponseArgs a
232 instance SchemaDoc d => CLI_Response (Schema d) where
233 type ResponseConstraint (Schema d) a = ()
234 type ResponseArgs (Schema d) a = SchemaResponseArgs a
235 type Response (Schema d) = ()
236 response' = Schema $ \_inh -> Nothing
238 -- ** Type 'SchemaPerm'
239 data SchemaPerm d k a = SchemaPerm
240 { schemaPerm_finalizer :: forall b c.
243 -- ^ Used to implement 'rule'.
244 , schemaPerm_alternatives :: [Schema d (a->k) k]
245 -- ^ Collect alternatives for rendering them all at once in 'runPermutation'.
247 instance Functor (SchemaPerm d k) where
248 _f`fmap`SchemaPerm fin ps = SchemaPerm fin (coerceSchema <$> ps)
249 instance Applicative (SchemaPerm d k) where
250 pure _a = SchemaPerm id mempty
251 SchemaPerm fd f <*> SchemaPerm fx x =
252 SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
253 instance SchemaDoc d => Permutable (Schema d) where
254 type Permutation (Schema d) = SchemaPerm d
255 runPermutation (SchemaPerm fin ps) =
257 [] -> fin $ Schema $ \_inh -> Nothing
258 _ -> fin $ Schema $ \inh -> Just $
259 Doc.intercalate Doc.breakspace $
260 catMaybes $ (<$> ps) $ \(Schema s) ->
262 { schemaInh_op=(op, SideL)
263 , schemaInh_or=docOrH }
265 toPermutation = SchemaPerm id . pure
266 toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $
267 if needsParenInfix (schemaInh_op inh) op
270 runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}
272 runSchema s inh{schemaInh_op=(op, SideL)}
274 instance SchemaDoc d => CLI_Help (SchemaPerm d) where
275 type HelpConstraint (SchemaPerm d) d' = d ~ d'
277 program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps
278 rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps