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 => Docable 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)
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 :: Docable d => SchemaInh d
68 defSchemaInh = SchemaInh
69 { schemaInh_op = (infixN0, SideL)
70 , schemaInh_define = True
71 , schemaInh_or = docOrH
74 pairIfNeeded :: Docable d => SchemaInh d -> Infix -> d -> d
75 pairIfNeeded SchemaInh{..} op =
76 if needsParenInfix schemaInh_op 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 Docable d => Functor (Schema d f) where
102 _f `fmap` Schema x = Schema $ \inh ->
103 pairIfNeeded inh op <$>
104 x inh{schemaInh_op=(op, SideR)}
108 instance Docable d => App (Schema d) where
109 Schema f <.> Schema x = Schema $ \inh ->
110 case (f inh{schemaInh_op=(op, SideL)}, x inh{schemaInh_op=(op, SideR)}) of
111 (Nothing, Nothing) -> Nothing
112 (Just f', Nothing) -> Just f'
113 (Nothing, Just x') -> Just x'
114 (Just f', Just x') -> Just $ pairIfNeeded inh op $ f' <> Doc.space <> x'
117 instance Docable d => Alt (Schema d) where
118 lp <!> rp = Schema $ \inh ->
119 case (unSchema lp inh, unSchema rp inh) of
120 (Nothing, Nothing) -> Nothing
121 (Just lp', Nothing) -> Just lp'
122 (Nothing, Just rp') -> Just rp'
123 (Just{}, Just{}) -> Just $
124 if needsParenInfix (schemaInh_op inh) op
128 -- Doc.withBreakable Nothing $
130 { schemaInh_op=(op, SideL)
131 , schemaInh_or=docOrH } <>
134 { schemaInh_op=(op, SideR)
135 , schemaInh_or=docOrH })
140 { schemaInh_op=(op, SideL)
141 , schemaInh_or=docOrV } <>
144 { schemaInh_op=(op, SideR)
145 , schemaInh_or=docOrV } <>
148 runSchema lp inh{schemaInh_op=(op, SideL)} <>
150 runSchema rp inh{schemaInh_op=(op, SideR)}
151 where op = infixB SideL 2
152 opt s = Schema $ \inh -> Just $
154 runSchema s inh{schemaInh_op=(op, SideL)}
156 instance Pro (Schema d) where
157 dimap _a2b _b2a = coerceSchema
158 instance Docable d => AltApp (Schema d) where
159 many0 s = Schema $ \inh -> Just $
160 runSchema s inh{schemaInh_op=(op, SideL)}<>"*"
162 many1 s = Schema $ \inh -> Just $
163 runSchema s inh{schemaInh_op=(op, SideL)}<>"..."
165 instance Docable d => CLI_Command (Schema d) where
166 -- type CommandConstraint (Schema d) a = ()
167 command n s = Schema $ \inh -> Just $
168 if schemaInh_define inh || List.null n
171 (fromString n <.> coerceSchema s)
172 inh{schemaInh_define = False}
179 Doc.from (Doc.Word n)
180 instance Docable d => CLI_Var (Schema d) where
181 type VarConstraint (Schema d) a = ()
182 var' n = Schema $ \_inh -> Just $
183 Doc.underline $ Doc.from $ Doc.Word n
184 just _ = Schema $ \_inh -> Nothing
185 nothing = Schema $ \_inh -> Nothing
186 instance Docable d => CLI_Env (Schema d) where
187 type EnvConstraint (Schema d) a = ()
188 env' n = Schema $ \_inh -> Nothing
189 -- NOTE: environment variables are not shown in the schema,
191 instance Docable d => CLI_Tag (Schema d) where
192 type TagConstraint (Schema d) a = ()
193 tagged n r = Schema $ \inh ->
194 unSchema (prefix n <.> r) inh
197 Tag s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
198 TagShort s -> fromString ['-', s]
199 TagLong l -> fromString ("--"<>l)
200 endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
201 instance Docable d => CLI_Help (Schema d) where
202 type HelpConstraint (Schema d) d' = d ~ d'
204 program n s = Schema $ \inh -> Just $
206 (fromString n <.> coerceSchema s)
207 inh{schemaInh_define = False}
208 rule n s = Schema $ \inh -> Just $
209 if schemaInh_define inh
210 then runSchema s inh{schemaInh_define=False}
217 Doc.from (Doc.Word n)
218 data SchemaResponseArgs a
219 instance Docable d => CLI_Response (Schema d) where
220 type ResponseConstraint (Schema d) a = ()
221 type ResponseArgs (Schema d) a = SchemaResponseArgs a
222 type Response (Schema d) = ()
223 response' = Schema $ \_inh -> Nothing
225 -- ** Type 'SchemaPerm'
226 data SchemaPerm d k a = SchemaPerm
227 { schemaPerm_finalizer :: forall b c. Schema d (b->c) c -> Schema d (b->c) c
228 -- ^ Used to implement 'rule'.
229 , schemaPerm_alternatives :: [Schema d (a->k) k]
230 -- ^ Collect alternatives for rendering them all at once in 'runPermutation'.
232 instance Functor (SchemaPerm d k) where
233 _f`fmap`SchemaPerm w ps = SchemaPerm w (coerceSchema <$> ps)
234 instance Applicative (SchemaPerm d k) where
235 pure _a = SchemaPerm id mempty
236 SchemaPerm fd w <*> SchemaPerm fx x =
237 SchemaPerm (fd . fx) $ (coerceSchema <$> w) <> (coerceSchema <$> x)
238 instance Docable d => Permutable (Schema d) where
239 type Permutation (Schema d) = SchemaPerm d
240 runPermutation (SchemaPerm w ps) =
242 [] -> w $ Schema $ \_inh -> Nothing
243 [Schema s] -> w $ Schema s
244 _ -> w $ Schema $ \inh -> Just $
245 -- pairIfNeeded inh op $
247 Doc.intercalate Doc.breakspace $
248 catMaybes $ (<$> ps) $ \(Schema s) ->
250 { schemaInh_op=(op, SideL)
251 , schemaInh_or=docOrH }
253 toPermutation = SchemaPerm id . pure
254 toPermDefault a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $
255 if needsParenInfix (schemaInh_op inh) op
259 -- Doc.withBreakable Nothing $
260 runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH})
264 runSchema s inh{schemaInh_op=(op, SideL)} <>
267 runSchema s inh{schemaInh_op=(op, SideL)}
269 instance Docable d => CLI_Help (SchemaPerm d) where
270 type HelpConstraint (SchemaPerm d) d' = d ~ d'
272 program n (SchemaPerm w ps) = SchemaPerm (program n . w) ps
273 rule n (SchemaPerm w ps) = SchemaPerm (rule n . w) ps