Symantic/CLI/Schema.hs

   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
   7
   8 import Control.Applicative (Applicative(..))
   9 import Data.Bool
  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
  23
  24 import Symantic.CLI.API
  25 import Symantic.CLI.Fixity
  26
  27 -- * Type 'Schema'
  28 newtype Schema d f k
  29  =      Schema { unSchema :: SchemaInh d -> Maybe d }
  30
  31 runSchema :: Monoid d => Schema d f k -> SchemaInh d -> d
  32 runSchema (Schema s) = fromMaybe mempty . s
  33
  34 docSchema :: Monoid d => SchemaDoc d => Schema d f k -> d
  35 docSchema s = runSchema s defSchemaInh
  36
  37 coerceSchema :: Schema d f k -> Schema d f' k'
  38 coerceSchema Schema{..} = Schema{..}
  39
  40 -- ** Class 'SchemaDoc'
  41 type SchemaDoc d =
  42  ( Semigroup d
  43  , Monoid d
  44  , IsString d
  45  , Doc.Colorable16 d
  46  , Doc.Decorable d
  47  , Doc.Spaceable d
  48  , Doc.Indentable d
  49  , Doc.Wrappable d
  50  , Doc.From (Doc.Word Char) d
  51  , Doc.From (Doc.Word Text) d
  52  , Doc.From (Doc.Word String) d
  53  )
  54
  55 -- ** Type 'SchemaInh'
  56 -- | Inherited top-down.
  57 data SchemaInh d
  58  =   SchemaInh
  59  {   schemaInh_op     :: (Infix, Side) -- ^ Parent operator.
  60  ,   schemaInh_define :: Bool          -- ^ Whether to print a definition, or not.
  61  ,   schemaInh_or     :: d
  62  }
  63
  64 defSchemaInh :: SchemaDoc d => SchemaInh d
  65 defSchemaInh = SchemaInh
  66  { schemaInh_op     = (infixN0, SideL)
  67  , schemaInh_define = True
  68  , schemaInh_or     = docOrH
  69  }
  70
  71 pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d
  72 pairIfNeeded opInh op =
  73         if needsParenInfix opInh op
  74         then Doc.align . Doc.parens
  75         else id
  76
  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
  81         mappend = (<>)
  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
  86         show =
  87                 TL.unpack .
  88                 TLB.toLazyText .
  89                 Doc.runPlain .
  90                 docSchema
  91
  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
  95
  96 {-
  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)}
 101                 where
 102                 op = infixB SideL 10
 103 -}
 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)}
 108                  Just fd ->
 109                         case x inh{schemaInh_op=(op, SideR)} of
 110                          Nothing -> Just fd
 111                          Just xd -> Just $
 112                                 pairIfNeeded (schemaInh_op inh) op $
 113                                 fd <> Doc.space <> xd
 114                 where
 115                 op = infixB SideL 10
 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
 126                         then
 127                                 -- NOTE: when parenthesis are needed
 128                                 -- first try to fit the alternative on a single line,
 129                                 -- otherwise align them on multiple lines.
 130                                 Doc.breakalt
 131                                  (Doc.parens $
 132                                         -- Doc.withBreakable Nothing $
 133                                         runSchema l inh
 134                                          { schemaInh_op=(op, SideL)
 135                                          , schemaInh_or=docOrH } <>
 136                                         docOrH <>
 137                                         runSchema r inh
 138                                          { schemaInh_op=(op, SideR)
 139                                          , schemaInh_or=docOrH })
 140                                  (Doc.align $
 141                                         Doc.parens $
 142                                         Doc.space <>
 143                                         runSchema l inh
 144                                          { schemaInh_op=(op, SideL)
 145                                          , schemaInh_or=docOrV } <>
 146                                         docOrV <>
 147                                         runSchema r inh
 148                                          { schemaInh_op=(op, SideR)
 149                                          , schemaInh_or=docOrV } <>
 150                                         Doc.newline)
 151                         else
 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)} <>
 156                                 schemaInh_or inh <>
 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 $
 161                 Doc.brackets $
 162                 runSchema s inh{schemaInh_op=(op, SideL)}
 163                 where op = infixN0
 164 instance SchemaDoc d => Sequenceable (Schema d) where
 165         type Sequence (Schema d) = SchemaSeq d
 166         runSequence (SchemaSeq fin ps) =
 167                 case ps of
 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) ->
 173                                 s inh
 174                                  { schemaInh_op=(op, SideL)
 175                                  , schemaInh_or=docOrH }
 176                 where op = infixN 10
 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) =
 181                 case ps of
 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) ->
 187                                 s inh
 188                                  { schemaInh_op=(op, SideL)
 189                                  , schemaInh_or=docOrH }
 190                 where op = infixN 10
 191         toPermutation = SchemaPerm id . pure
 192         toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $
 193                 if needsParenInfix (schemaInh_op inh) op
 194                 then
 195                         Doc.brackets $
 196                                 runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}
 197                 else
 198                         runSchema s inh{schemaInh_op=(op, SideL)}
 199                 where op = infixN0
 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)}<>"*"
 206                 where op = infixN 11
 207         many1 s = Schema $ \inh -> Just $
 208                 pairIfNeeded (schemaInh_op inh) op $
 209                 runSchema s inh{schemaInh_op=(op, SideL)}<>"+"
 210                 where op = infixN 11
 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
 215                 then
 216                         Doc.align $
 217                         runSchema
 218                          (fromString n <.> coerceSchema s)
 219                          inh{schemaInh_define = False}
 220                 else ref
 221                 where
 222                 ref =
 223                         Doc.bold $
 224                         Doc.angles $
 225                         Doc.magentaer $
 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         just _  = Schema $ \_inh -> Nothing
 232         nothing = Schema $ \_inh -> Nothing
 233 instance SchemaDoc d => CLI_Env (Schema d) where
 234         type EnvConstraint (Schema d) a = ()
 235         env' _n = Schema $ \_inh -> Nothing
 236          -- NOTE: environment variables are not shown in the schema,
 237          -- only in the help.
 238 instance SchemaDoc d => CLI_Tag (Schema d) where
 239         type TagConstraint (Schema d) a = ()
 240         tagged n r = Schema $ \inh ->
 241                 unSchema (prefix n <.> r) inh
 242                 where
 243                 prefix = \case
 244                  Tag      s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
 245                  TagShort s   -> fromString ['-', s]
 246                  TagLong  l   -> fromString ("--"<>l)
 247         endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
 248 instance SchemaDoc d => CLI_Help (Schema d) where
 249         type HelpConstraint (Schema d) d' = d ~ d'
 250         help _msg = id
 251         program n s = Schema $ \inh -> Just $
 252                 runSchema
 253                  (fromString n <.> coerceSchema s)
 254                  inh{schemaInh_define = False}
 255         rule n s = Schema $ \inh -> Just $
 256                 if schemaInh_define inh
 257                 then runSchema s inh{schemaInh_define=False}
 258                 else ref
 259                 where
 260                 ref =
 261                         Doc.bold $
 262                         Doc.angles $
 263                         Doc.magentaer $
 264                         Doc.from (Doc.Word n)
 265 data SchemaResponseArgs a
 266 instance SchemaDoc d => CLI_Response (Schema d) where
 267         type ResponseConstraint (Schema d) a = ()
 268         type ResponseArgs (Schema d) a = SchemaResponseArgs a
 269         type Response (Schema d) = ()
 270         response' = Schema $ \_inh -> Nothing
 271
 272 -- ** Type 'SchemaSeq'
 273 data SchemaSeq d k a = SchemaSeq
 274  { schemaSeq_finalizer :: forall b c.
 275                            Schema d (b->c) c ->
 276                            Schema d (b->c) c
 277    -- ^ Used to implement 'rule'.
 278  , schemaSeq_alternatives :: [Schema d (a->k) k]
 279    -- ^ Collect alternatives for rendering them all at once in 'runSequence'.
 280  }
 281 instance Functor (SchemaSeq d k) where
 282         _f`fmap`SchemaSeq fin ps = SchemaSeq fin (coerceSchema <$> ps)
 283 instance Applicative (SchemaSeq d k) where
 284         pure _a = SchemaSeq id mempty
 285         SchemaSeq fd f <*> SchemaSeq fx x =
 286                 SchemaSeq (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
 287 instance SchemaDoc d => CLI_Help (SchemaSeq d) where
 288         type HelpConstraint (SchemaSeq d) d' = d ~ d'
 289         help _msg = id
 290         program n (SchemaSeq fin ps) = SchemaSeq (program n . fin) ps
 291         rule n (SchemaSeq fin ps) = SchemaSeq (rule n . fin) ps
 292
 293 -- ** Type 'SchemaPerm'
 294 data SchemaPerm d k a = SchemaPerm
 295  { schemaPerm_finalizer :: forall b c.
 296                            Schema d (b->c) c ->
 297                            Schema d (b->c) c
 298    -- ^ Used to implement 'rule'.
 299  , schemaPerm_alternatives :: [Schema d (a->k) k]
 300    -- ^ Collect alternatives for rendering them all at once in 'runPermutation'.
 301  }
 302 instance Functor (SchemaPerm d k) where
 303         _f`fmap`SchemaPerm fin ps = SchemaPerm fin (coerceSchema <$> ps)
 304 instance Applicative (SchemaPerm d k) where
 305         pure _a = SchemaPerm id mempty
 306         SchemaPerm fd f <*> SchemaPerm fx x =
 307                 SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
 308 instance SchemaDoc d => CLI_Help (SchemaPerm d) where
 309         type HelpConstraint (SchemaPerm d) d' = d ~ d'
 310         help _msg = id
 311         program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps
 312         rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps