{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.CLI.Schema where
import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Char (Char)
import Data.Function (($), (.), id)
import Data.Functor (Functor(..), (<$>))
import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Symantic.Document as Doc
import Symantic.CLI.API
import Symantic.CLI.Fixity
newtype Schema d f k
= Schema { unSchema :: SchemaInh d -> Maybe d }
runSchema :: Monoid d => Schema d f k -> SchemaInh d -> d
runSchema (Schema s) = fromMaybe mempty . s
docSchema :: Monoid d => SchemaDoc d => Schema d f k -> d
docSchema s = runSchema s defSchemaInh
coerceSchema :: Schema d f k -> Schema d f' k'
coerceSchema Schema{..} = Schema{..}
type SchemaDoc d =
( Semigroup d
, Monoid d
, IsString d
, Doc.Colorable16 d
, Doc.Decorable d
, Doc.Spaceable d
, Doc.Indentable d
, Doc.Wrappable d
, Doc.From (Doc.Word Char) d
, Doc.From (Doc.Word Text) d
, Doc.From (Doc.Word String) d
)
data SchemaInh d
= SchemaInh
{ schemaInh_op :: (Infix, Side)
, schemaInh_define :: Bool
, schemaInh_or :: d
}
defSchemaInh :: SchemaDoc d => SchemaInh d
defSchemaInh = SchemaInh
{ schemaInh_op = (infixN0, SideL)
, schemaInh_define = True
, schemaInh_or = docOrH
}
pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d
pairIfNeeded opInh op =
if needsParenInfix opInh op
then Doc.align . Doc.parens
else id
instance Semigroup d => Semigroup (Schema d f k) where
Schema x <> Schema y = Schema $ x <> y
instance (Semigroup d, Monoid d) => Monoid (Schema d f k) where
mempty = Schema mempty
mappend = (<>)
instance (Semigroup d, IsString d) => IsString (Schema d f k) where
fromString "" = Schema $ \_inh -> Nothing
fromString s = Schema $ \_inh -> Just $ fromString s
instance Show (Schema (Doc.Plain TLB.Builder) a k) where
show =
TL.unpack .
TLB.toLazyText .
Doc.runPlain .
docSchema
docOrH, docOrV :: Doc.Spaceable d => Doc.From (Doc.Word Char) d => d
docOrH = Doc.space <> Doc.from (Doc.Word '|') <> Doc.space
docOrV = Doc.newline <> Doc.from (Doc.Word '|') <> Doc.space
instance SchemaDoc d => App (Schema d) where
Schema f <.> Schema x = Schema $ \inh ->
case f inh{schemaInh_op=(op, SideL)} of
Nothing -> x inh{schemaInh_op=(op, SideR)}
Just fd ->
case x inh{schemaInh_op=(op, SideR)} of
Nothing -> Just fd
Just xd -> Just $
pairIfNeeded (schemaInh_op inh) op $
fd <> Doc.space <> xd
where
op = infixB SideL 10
instance SchemaDoc d => Alt (Schema d) where
l <!> r = Schema $ \inh ->
case (unSchema l inh, unSchema r inh) of
(Nothing, Nothing) -> Nothing
(Just ld, Nothing) -> Just ld
(Nothing, Just rd) -> Just rd
(Just{}, Just{}) -> Just $
if needsParenInfix (schemaInh_op inh) op
then
Doc.breakalt
(Doc.parens $
runSchema l inh
{ schemaInh_op=(op, SideL)
, schemaInh_or=docOrH } <>
docOrH <>
runSchema r inh
{ schemaInh_op=(op, SideR)
, schemaInh_or=docOrH })
(Doc.align $
Doc.parens $
Doc.space <>
runSchema l inh
{ schemaInh_op=(op, SideL)
, schemaInh_or=docOrV } <>
docOrV <>
runSchema r inh
{ schemaInh_op=(op, SideR)
, schemaInh_or=docOrV } <>
Doc.newline)
else
runSchema l inh{schemaInh_op=(op, SideL)} <>
schemaInh_or inh <>
runSchema r inh{schemaInh_op=(op, SideR)}
where op = infixB SideL 2
alt x y = coerceSchema $ coerceSchema x <!> coerceSchema y
opt s = Schema $ \inh -> Just $
Doc.brackets $
runSchema s inh{schemaInh_op=(op, SideL)}
where op = infixN0
instance SchemaDoc d => Sequenceable (Schema d) where
type Sequence (Schema d) = SchemaSeq d
runSequence (SchemaSeq fin ps) =
case ps of
[] -> fin $ Schema $ \_inh -> Nothing
_ -> fin $ Schema $ \inh -> Just $
pairIfNeeded (schemaInh_op inh) op $
Doc.intercalate Doc.breakspace $
catMaybes $ (<$> ps) $ \(Schema s) ->
s inh
{ schemaInh_op=(op, SideL)
, schemaInh_or=docOrH }
where op = infixN 10
toSequence = SchemaSeq id . pure
instance SchemaDoc d => Permutable (Schema d) where
type Permutation (Schema d) = SchemaPerm d
runPermutation (SchemaPerm fin ps) =
case ps of
[] -> fin $ Schema $ \_inh -> Nothing
_ -> fin $ Schema $ \inh -> Just $
pairIfNeeded (schemaInh_op inh) op $
Doc.intercalate Doc.breakspace $
catMaybes $ (<$> ps) $ \(Schema s) ->
s inh
{ schemaInh_op=(op, SideL)
, schemaInh_or=docOrH }
where op = infixN 10
toPermutation = SchemaPerm id . pure
toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $
if needsParenInfix (schemaInh_op inh) op
then
Doc.brackets $
runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}
else
runSchema s inh{schemaInh_op=(op, SideL)}
where op = infixN0
instance Pro (Schema d) where
dimap _a2b _b2a = coerceSchema
instance SchemaDoc d => AltApp (Schema d) where
many0 s = Schema $ \inh -> Just $
pairIfNeeded (schemaInh_op inh) op $
runSchema s inh{schemaInh_op=(op, SideL)}<>"*"
where op = infixN 11
many1 s = Schema $ \inh -> Just $
pairIfNeeded (schemaInh_op inh) op $
runSchema s inh{schemaInh_op=(op, SideL)}<>"+"
where op = infixN 11
instance SchemaDoc d => CLI_Command (Schema d) where
command n s = Schema $ \inh -> Just $
if schemaInh_define inh || List.null n
then
Doc.align $
runSchema
(fromString n <.> coerceSchema s)
inh{schemaInh_define = False}
else ref
where
ref =
Doc.bold $
Doc.angles $
Doc.magentaer $
Doc.from (Doc.Word n)
instance SchemaDoc d => CLI_Var (Schema d) where
type VarConstraint (Schema d) a = ()
var' n = Schema $ \_inh -> Just $
Doc.underline $ Doc.from $ Doc.Word n
instance SchemaDoc d => CLI_Constant (Schema d) where
constant c _a = Schema $ \inh -> Just $
Doc.from (Doc.Word c)
just _ = Schema $ \_inh -> Nothing
nothing = Schema $ \_inh -> Nothing
instance SchemaDoc d => CLI_Env (Schema d) where
type EnvConstraint (Schema d) a = ()
env' _n = Schema $ \_inh -> Nothing
instance SchemaDoc d => CLI_Tag (Schema d) where
type TagConstraint (Schema d) a = ()
tag n r = Schema $ \inh ->
unSchema (prefix n <.> r) inh
where
prefix = \case
Tag s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
TagShort s -> fromString ['-', s]
TagLong l -> fromString ("--"<>l)
endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
instance SchemaDoc d => CLI_Help (Schema d) where
type HelpConstraint (Schema d) d' = d ~ d'
help _msg = id
program n s = Schema $ \inh -> Just $
runSchema
(fromString n <.> coerceSchema s)
inh{schemaInh_define = False}
rule n s = Schema $ \inh -> Just $
if schemaInh_define inh
then runSchema s inh{schemaInh_define=False}
else ref
where
ref =
Doc.bold $
Doc.angles $
Doc.magentaer $
Doc.from (Doc.Word n)
data SchemaResponseArgs a
instance SchemaDoc d => CLI_Response (Schema d) where
type ResponseConstraint (Schema d) a = ()
type ResponseArgs (Schema d) a = SchemaResponseArgs a
type Response (Schema d) = ()
response' = Schema $ \_inh -> Nothing
data SchemaSeq d k a = SchemaSeq
{ schemaSeq_finalizer :: forall b c.
Schema d (b->c) c ->
Schema d (b->c) c
, schemaSeq_alternatives :: [Schema d (a->k) k]
}
instance Functor (SchemaSeq d k) where
_f`fmap`SchemaSeq fin ps = SchemaSeq fin (coerceSchema <$> ps)
instance Applicative (SchemaSeq d k) where
pure _a = SchemaSeq id mempty
SchemaSeq fd f <*> SchemaSeq fx x =
SchemaSeq (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
instance SchemaDoc d => CLI_Help (SchemaSeq d) where
type HelpConstraint (SchemaSeq d) d' = d ~ d'
help _msg = id
program n (SchemaSeq fin ps) = SchemaSeq (program n . fin) ps
rule n (SchemaSeq fin ps) = SchemaSeq (rule n . fin) ps
data SchemaPerm d k a = SchemaPerm
{ schemaPerm_finalizer :: forall b c.
Schema d (b->c) c ->
Schema d (b->c) c
, schemaPerm_alternatives :: [Schema d (a->k) k]
}
instance Functor (SchemaPerm d k) where
_f`fmap`SchemaPerm fin ps = SchemaPerm fin (coerceSchema <$> ps)
instance Applicative (SchemaPerm d k) where
pure _a = SchemaPerm id mempty
SchemaPerm fd f <*> SchemaPerm fx x =
SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
instance SchemaDoc d => CLI_Help (SchemaPerm d) where
type HelpConstraint (SchemaPerm d) d' = d ~ d'
help _msg = id
program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps
rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps