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 -- ** Type 'Doc'
  41 type Doc = Doc.AnsiText (Doc.Plain TLB.Builder)
  42
  43 -- ** Class 'SchemaDoc'
  44 type SchemaDoc d =
  45  ( Semigroup d
  46  , Monoid d
  47  , IsString d
  48  , Doc.Colorable16 d
  49  , Doc.Decorable d
  50  , Doc.Spaceable d
  51  , Doc.Indentable d
  52  , Doc.Wrappable d
  53  , Doc.From (Doc.Word Char) d
  54  , Doc.From (Doc.Word Text) d
  55  , Doc.From (Doc.Word String) d
  56  )
  57
  58 -- ** Type 'SchemaInh'
  59 -- | Inherited top-down.
  60 data SchemaInh d
  61  =   SchemaInh
  62  {   schemaInh_op     :: (Infix, Side) -- ^ Parent operator.
  63  ,   schemaInh_define :: Bool          -- ^ Whether to print a definition, or not.
  64  ,   schemaInh_or     :: d
  65  }
  66
  67 defSchemaInh :: SchemaDoc d => SchemaInh d
  68 defSchemaInh = SchemaInh
  69  { schemaInh_op     = (infixN0, SideL)
  70  , schemaInh_define = True
  71  , schemaInh_or     = docOrH
  72  }
  73
  74 pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d
  75 pairIfNeeded opInh op =
  76         if needsParenInfix opInh op
  77         then Doc.align . Doc.parens
  78         else id
  79
  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
  84         mappend = (<>)
  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
  89         show =
  90                 TL.unpack .
  91                 TLB.toLazyText .
  92                 Doc.runPlain .
  93                 Doc.runAnsiText .
  94                 docSchema
  95
  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
  99
 100 {-
 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)}
 105                 where
 106                 op = infixB SideL 10
 107 -}
 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)}
 112                  Just fd ->
 113                         case x inh{schemaInh_op=(op, SideR)} of
 114                          Nothing -> Just fd
 115                          Just xd -> Just $
 116                                 pairIfNeeded (schemaInh_op inh) op $
 117                                 fd <> Doc.space <> xd
 118                 where
 119                 op = infixB SideL 10
 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
 130                         then
 131                                 -- NOTE: when parenthesis are needed
 132                                 -- first try to fit the alternative on a single line,
 133                                 -- otherwise align them on multiple lines.
 134                                 Doc.breakalt
 135                                  (Doc.parens $
 136                                         -- Doc.withBreakable Nothing $
 137                                         runSchema l inh
 138                                          { schemaInh_op=(op, SideL)
 139                                          , schemaInh_or=docOrH } <>
 140                                         docOrH <>
 141                                         runSchema r inh
 142                                          { schemaInh_op=(op, SideR)
 143                                          , schemaInh_or=docOrH })
 144                                  (Doc.align $
 145                                         Doc.parens $
 146                                         Doc.space <>
 147                                         runSchema l inh
 148                                          { schemaInh_op=(op, SideL)
 149                                          , schemaInh_or=docOrV } <>
 150                                         docOrV <>
 151                                         runSchema r inh
 152                                          { schemaInh_op=(op, SideR)
 153                                          , schemaInh_or=docOrV } <>
 154                                         Doc.newline)
 155                         else
 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)} <>
 160                                 schemaInh_or inh <>
 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 $
 165                 Doc.brackets $
 166                 runSchema s inh{schemaInh_op=(op, SideL)}
 167                 where op = infixN0
 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)}<>"*"
 173                 where op = infixN 10
 174         many1 s = Schema $ \inh -> Just $
 175                 runSchema s inh{schemaInh_op=(op, SideL)}<>"..."
 176                 where op = infixN 10
 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
 181                 then
 182                         Doc.align $
 183                         runSchema
 184                          (fromString n <.> coerceSchema s)
 185                          inh{schemaInh_define = False}
 186                 else ref
 187                 where
 188                 ref =
 189                         Doc.bold $
 190                         Doc.angles $
 191                         Doc.magentaer $
 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,
 203          -- only in the help.
 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
 208                 where
 209                 prefix = \case
 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'
 216         help _msg = id
 217         program n s = Schema $ \inh -> Just $
 218                 runSchema
 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}
 224                 else ref
 225                 where
 226                 ref =
 227                         Doc.bold $
 228                         Doc.angles $
 229                         Doc.magentaer $
 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
 237
 238 -- ** Type 'SchemaPerm'
 239 data SchemaPerm d k a = SchemaPerm
 240  { schemaPerm_finalizer :: forall b c.
 241                            Schema d (b->c) c ->
 242                            Schema d (b->c) 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'.
 246  }
 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) =
 256                 case ps of
 257                  [] -> fin $ Schema $ \_inh -> Nothing
 258                  _ -> fin $ Schema $ \inh -> Just $
 259                         Doc.intercalate Doc.breakspace $
 260                         catMaybes $ (<$> ps) $ \(Schema s) ->
 261                                 s inh
 262                                  { schemaInh_op=(op, SideL)
 263                                  , schemaInh_or=docOrH }
 264                 where op = infixN 10
 265         toPermutation = SchemaPerm id . pure
 266         toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $
 267                 if needsParenInfix (schemaInh_op inh) op
 268                 then
 269                         Doc.brackets $
 270                                 runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}
 271                 else
 272                         runSchema s inh{schemaInh_op=(op, SideL)}
 273                 where op = infixN0
 274 instance SchemaDoc d => CLI_Help (SchemaPerm d) where
 275         type HelpConstraint (SchemaPerm d) d' = d ~ d'
 276         help _msg = id
 277         program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps
 278         rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps