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