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 Pro (Schema d) where
 165         dimap _a2b _b2a = coerceSchema
 166 instance SchemaDoc d => AltApp (Schema d) where
 167         many0 s = Schema $ \inh -> Just $
 168                 runSchema s inh{schemaInh_op=(op, SideL)}<>"*"
 169                 where op = infixN 10
 170         many1 s = Schema $ \inh -> Just $
 171                 runSchema s inh{schemaInh_op=(op, SideL)}<>"+"
 172                 where op = infixN 10
 173 instance SchemaDoc d => CLI_Command (Schema d) where
 174         -- type CommandConstraint (Schema d) a = ()
 175         command n s = Schema $ \inh -> Just $
 176                 if schemaInh_define inh || List.null n
 177                 then
 178                         Doc.align $
 179                         runSchema
 180                          (fromString n <.> coerceSchema s)
 181                          inh{schemaInh_define = False}
 182                 else ref
 183                 where
 184                 ref =
 185                         Doc.bold $
 186                         Doc.angles $
 187                         Doc.magentaer $
 188                         Doc.from (Doc.Word n)
 189 instance SchemaDoc d => CLI_Var (Schema d) where
 190         type VarConstraint (Schema d) a = ()
 191         var' n = Schema $ \_inh -> Just $
 192                 Doc.underline $ Doc.from $ Doc.Word n
 193         just _  = Schema $ \_inh -> Nothing
 194         nothing = Schema $ \_inh -> Nothing
 195 instance SchemaDoc d => CLI_Env (Schema d) where
 196         type EnvConstraint (Schema d) a = ()
 197         env' _n = Schema $ \_inh -> Nothing
 198          -- NOTE: environment variables are not shown in the schema,
 199          -- only in the help.
 200 instance SchemaDoc d => CLI_Tag (Schema d) where
 201         type TagConstraint (Schema d) a = ()
 202         tagged n r = Schema $ \inh ->
 203                 unSchema (prefix n <.> r) inh
 204                 where
 205                 prefix = \case
 206                  Tag      s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
 207                  TagShort s   -> fromString ['-', s]
 208                  TagLong  l   -> fromString ("--"<>l)
 209         endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
 210 instance SchemaDoc d => CLI_Help (Schema d) where
 211         type HelpConstraint (Schema d) d' = d ~ d'
 212         help _msg = id
 213         program n s = Schema $ \inh -> Just $
 214                 runSchema
 215                  (fromString n <.> coerceSchema s)
 216                  inh{schemaInh_define = False}
 217         rule n s = Schema $ \inh -> Just $
 218                 if schemaInh_define inh
 219                 then runSchema s 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 data SchemaResponseArgs a
 228 instance SchemaDoc d => CLI_Response (Schema d) where
 229         type ResponseConstraint (Schema d) a = ()
 230         type ResponseArgs (Schema d) a = SchemaResponseArgs a
 231         type Response (Schema d) = ()
 232         response' = Schema $ \_inh -> Nothing
 233
 234 -- ** Type 'SchemaPerm'
 235 data SchemaPerm d k a = SchemaPerm
 236  { schemaPerm_finalizer :: forall b c.
 237                            Schema d (b->c) c ->
 238                            Schema d (b->c) c
 239    -- ^ Used to implement 'rule'.
 240  , schemaPerm_alternatives :: [Schema d (a->k) k]
 241    -- ^ Collect alternatives for rendering them all at once in 'runPermutation'.
 242  }
 243 instance Functor (SchemaPerm d k) where
 244         _f`fmap`SchemaPerm fin ps = SchemaPerm fin (coerceSchema <$> ps)
 245 instance Applicative (SchemaPerm d k) where
 246         pure _a = SchemaPerm id mempty
 247         SchemaPerm fd f <*> SchemaPerm fx x =
 248                 SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
 249 instance SchemaDoc d => Permutable (Schema d) where
 250         type Permutation (Schema d) = SchemaPerm d
 251         runPermutation (SchemaPerm fin ps) =
 252                 case ps of
 253                  [] -> fin $ Schema $ \_inh -> Nothing
 254                  _ -> fin $ Schema $ \inh -> Just $
 255                         Doc.intercalate Doc.breakspace $
 256                         catMaybes $ (<$> ps) $ \(Schema s) ->
 257                                 s inh
 258                                  { schemaInh_op=(op, SideL)
 259                                  , schemaInh_or=docOrH }
 260                 where op = infixN 10
 261         toPermutation = SchemaPerm id . pure
 262         toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $
 263                 if needsParenInfix (schemaInh_op inh) op
 264                 then
 265                         Doc.brackets $
 266                                 runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}
 267                 else
 268                         runSchema s inh{schemaInh_op=(op, SideL)}
 269                 where op = infixN0
 270 instance SchemaDoc d => CLI_Help (SchemaPerm d) where
 271         type HelpConstraint (SchemaPerm d) d' = d ~ d'
 272         help _msg = id
 273         program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps
 274         rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps