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