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         opt s = Schema $ \inh -> Just $
 153                 Doc.brackets $
 154                 runSchema s inh{schemaInh_op=(op, SideL)}
 155                 where op = infixN0
 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)}<>"*"
 161                 where op = infixN 10
 162         many1 s = Schema $ \inh -> Just $
 163                 runSchema s inh{schemaInh_op=(op, SideL)}<>"..."
 164                 where op = infixN 10
 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
 169                 then
 170                         runSchema
 171                          (fromString n <.> coerceSchema s)
 172                          inh{schemaInh_define = False}
 173                 else ref
 174                 where
 175                 ref =
 176                         Doc.bold $
 177                         Doc.angles $
 178                         Doc.magentaer $
 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,
 190          -- only in the help.
 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
 195                 where
 196                 prefix = \case
 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'
 203         help _msg = id
 204         program n s = Schema $ \inh -> Just $
 205                 runSchema
 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}
 211                 else ref
 212                 where
 213                 ref =
 214                         Doc.bold $
 215                         Doc.angles $
 216                         Doc.magentaer $
 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
 224
 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'.
 231  }
 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) =
 241                 case ps of
 242                  [] -> w $ Schema $ \_inh -> Nothing
 243                  [Schema s] -> w $ Schema s
 244                  _ -> w $ Schema $ \inh -> Just $
 245                         -- pairIfNeeded inh op $
 246                         Doc.align $
 247                         Doc.intercalate Doc.breakspace $
 248                         catMaybes $ (<$> ps) $ \(Schema s) ->
 249                                 s inh
 250                                  { schemaInh_op=(op, SideL)
 251                                  , schemaInh_or=docOrH }
 252                         where op = infixN 10
 253         toPermutation = SchemaPerm id . pure
 254         toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $
 255                 if needsParenInfix (schemaInh_op inh) op
 256                 then
 257                         Doc.breakalt
 258                          (Doc.brackets $
 259                                 -- Doc.withBreakable Nothing $
 260                                 runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH})
 261                          (Doc.align $
 262                                 Doc.brackets $
 263                                 Doc.space <>
 264                                 runSchema s inh{schemaInh_op=(op, SideL)} <>
 265                                 Doc.newline)
 266                 else
 267                         runSchema s inh{schemaInh_op=(op, SideL)}
 268                 where op = infixN0
 269 instance Docable d => CLI_Help (SchemaPerm d) where
 270         type HelpConstraint (SchemaPerm d) d' = d ~ d'
 271         help _msg = id
 272         program n (SchemaPerm w ps) = SchemaPerm (program n . w) ps
 273         rule n (SchemaPerm w ps) = SchemaPerm (rule n . w) ps