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 => Docable 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 'Docable'
  44 type Docable 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 :: Docable d => SchemaInh d
  68 defSchemaInh = SchemaInh
  69  { schemaInh_op     = (infixN0, SideL)
  70  , schemaInh_define = True
  71  , schemaInh_or     = docOrH
  72  }
  73
  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
  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 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)}
 105                 where
 106                 op = infixB SideL 10
 107 -}
 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'
 115                 where
 116                 op = infixB SideL 10
 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
 125                         then
 126                                 Doc.breakalt
 127                                  (Doc.parens $
 128                                         -- Doc.withBreakable Nothing $
 129                                         runSchema lp inh
 130                                          { schemaInh_op=(op, SideL)
 131                                          , schemaInh_or=docOrH } <>
 132                                         docOrH <>
 133                                         runSchema rp inh
 134                                          { schemaInh_op=(op, SideR)
 135                                          , schemaInh_or=docOrH })
 136                                  (Doc.align $
 137                                         Doc.parens $
 138                                         Doc.space <>
 139                                         runSchema lp inh
 140                                          { schemaInh_op=(op, SideL)
 141                                          , schemaInh_or=docOrV } <>
 142                                         docOrV <>
 143                                         runSchema rp inh
 144                                          { schemaInh_op=(op, SideR)
 145                                          , schemaInh_or=docOrV } <>
 146                                         Doc.newline)
 147                         else
 148                                 runSchema lp inh{schemaInh_op=(op, SideL)} <>
 149                                 schemaInh_or inh <>
 150                                 runSchema rp inh{schemaInh_op=(op, SideR)}
 151                 where op = infixB SideL 2
 152         alt x y = coerceSchema $ coerceSchema x <!> coerceSchema y
 153         opt s = Schema $ \inh -> Just $
 154                 Doc.brackets $
 155                 runSchema s inh{schemaInh_op=(op, SideL)}
 156                 where op = infixN0
 157 instance Pro (Schema d) where
 158         dimap _a2b _b2a = coerceSchema
 159 instance Docable d => AltApp (Schema d) where
 160         many0 s = Schema $ \inh -> Just $
 161                 runSchema s inh{schemaInh_op=(op, SideL)}<>"*"
 162                 where op = infixN 10
 163         many1 s = Schema $ \inh -> Just $
 164                 runSchema s inh{schemaInh_op=(op, SideL)}<>"..."
 165                 where op = infixN 10
 166 instance Docable d => CLI_Command (Schema d) where
 167         -- type CommandConstraint (Schema d) a = ()
 168         command n s = Schema $ \inh -> Just $
 169                 if schemaInh_define inh || List.null n
 170                 then
 171                         runSchema
 172                          (fromString n <.> coerceSchema s)
 173                          inh{schemaInh_define = False}
 174                 else ref
 175                 where
 176                 ref =
 177                         Doc.bold $
 178                         Doc.angles $
 179                         Doc.magentaer $
 180                         Doc.from (Doc.Word n)
 181 instance Docable d => CLI_Var (Schema d) where
 182         type VarConstraint (Schema d) a = ()
 183         var' n = Schema $ \_inh -> Just $
 184                 Doc.underline $ Doc.from $ Doc.Word n
 185         just _  = Schema $ \_inh -> Nothing
 186         nothing = Schema $ \_inh -> Nothing
 187 instance Docable d => CLI_Env (Schema d) where
 188         type EnvConstraint (Schema d) a = ()
 189         env' _n = Schema $ \_inh -> Nothing
 190          -- NOTE: environment variables are not shown in the schema,
 191          -- only in the help.
 192 instance Docable d => CLI_Tag (Schema d) where
 193         type TagConstraint (Schema d) a = ()
 194         tagged n r = Schema $ \inh ->
 195                 unSchema (prefix n <.> r) inh
 196                 where
 197                 prefix = \case
 198                  Tag      s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
 199                  TagShort s   -> fromString ['-', s]
 200                  TagLong  l   -> fromString ("--"<>l)
 201         endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
 202 instance Docable d => CLI_Help (Schema d) where
 203         type HelpConstraint (Schema d) d' = d ~ d'
 204         help _msg = id
 205         program n s = Schema $ \inh -> Just $
 206                 runSchema
 207                  (fromString n <.> coerceSchema s)
 208                  inh{schemaInh_define = False}
 209         rule n s = Schema $ \inh -> Just $
 210                 if schemaInh_define inh
 211                 then runSchema s inh{schemaInh_define=False}
 212                 else ref
 213                 where
 214                 ref =
 215                         Doc.bold $
 216                         Doc.angles $
 217                         Doc.magentaer $
 218                         Doc.from (Doc.Word n)
 219 data SchemaResponseArgs a
 220 instance Docable d => CLI_Response (Schema d) where
 221         type ResponseConstraint (Schema d) a = ()
 222         type ResponseArgs (Schema d) a = SchemaResponseArgs a
 223         type Response (Schema d) = ()
 224         response' = Schema $ \_inh -> Nothing
 225
 226 -- ** Type 'SchemaPerm'
 227 data SchemaPerm d k a = SchemaPerm
 228  { schemaPerm_finalizer    :: forall b c. Schema d (b->c) c -> Schema d (b->c) c
 229    -- ^ Used to implement 'rule'.
 230  , schemaPerm_alternatives :: [Schema d (a->k) k]
 231    -- ^ Collect alternatives for rendering them all at once in 'runPermutation'.
 232  }
 233 instance Functor (SchemaPerm d k) where
 234         _f`fmap`SchemaPerm w ps = SchemaPerm w (coerceSchema <$> ps)
 235 instance Applicative (SchemaPerm d k) where
 236         pure _a = SchemaPerm id mempty
 237         SchemaPerm fd w <*> SchemaPerm fx x =
 238                 SchemaPerm (fd . fx) $ (coerceSchema <$> w) <> (coerceSchema <$> x)
 239 instance Docable d => Permutable (Schema d) where
 240         type Permutation (Schema d) = SchemaPerm d
 241         runPermutation (SchemaPerm w ps) =
 242                 case ps of
 243                  [] -> w $ Schema $ \_inh -> Nothing
 244                  [Schema s] -> w $ Schema s
 245                  _ -> w $ Schema $ \inh -> Just $
 246                         -- pairIfNeeded inh op $
 247                         Doc.align $
 248                         Doc.intercalate Doc.breakspace $
 249                         catMaybes $ (<$> ps) $ \(Schema s) ->
 250                                 s inh
 251                                  { schemaInh_op=(op, SideL)
 252                                  , schemaInh_or=docOrH }
 253                         where op = infixN 10
 254         toPermutation = SchemaPerm id . pure
 255         toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $
 256                 if needsParenInfix (schemaInh_op inh) op
 257                 then
 258                         Doc.breakalt
 259                          (Doc.brackets $
 260                                 -- Doc.withBreakable Nothing $
 261                                 runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH})
 262                          (Doc.align $
 263                                 Doc.brackets $
 264                                 Doc.space <>
 265                                 runSchema s inh{schemaInh_op=(op, SideL)} <>
 266                                 Doc.newline)
 267                 else
 268                         runSchema s inh{schemaInh_op=(op, SideL)}
 269                 where op = infixN0
 270 instance Docable d => CLI_Help (SchemaPerm d) where
 271         type HelpConstraint (SchemaPerm d) d' = d ~ d'
 272         help _msg = id
 273         program n (SchemaPerm w ps) = SchemaPerm (program n . w) ps
 274         rule n (SchemaPerm w ps) = SchemaPerm (rule n . w) ps