Schema.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
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

-- * Type 'Schema'
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 => Docable d => Schema d f k -> d
docSchema s = runSchema s defSchemaInh

coerceSchema :: Schema d f k -> Schema d f' k'
coerceSchema Schema{..} = Schema{..}

-- ** Type 'Doc'
type Doc = Doc.AnsiText (Doc.Plain TLB.Builder)

-- ** Class 'Docable'
type Docable 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
 )

-- ** Type 'SchemaInh'
-- | Inherited top-down.
data SchemaInh d
 =   SchemaInh
 {   schemaInh_op     :: (Infix, Side) -- ^ Parent operator.
 ,   schemaInh_define :: Bool          -- ^ Whether to print a definition, or not.
 ,   schemaInh_or     :: d
 }

defSchemaInh :: Docable d => SchemaInh d
defSchemaInh = SchemaInh
 { schemaInh_op     = (infixN0, SideL)
 , schemaInh_define = True
 , schemaInh_or     = docOrH
 }

pairIfNeeded :: Docable d => SchemaInh d -> Infix -> d -> d
pairIfNeeded SchemaInh{..} op =
	if needsParenInfix schemaInh_op 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 a k) where
	show =
		TL.unpack .
		TLB.toLazyText .
		Doc.runPlain .
		Doc.runAnsiText .
		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 Docable d => Functor (Schema d f) where
	_f `fmap` Schema x = Schema $ \inh ->
		pairIfNeeded inh op <$>
		x inh{schemaInh_op=(op, SideR)}
		where
		op = infixB SideL 10
-}
instance Docable d => App (Schema d) where
	Schema f <.> Schema x = Schema $ \inh ->
		case (f inh{schemaInh_op=(op, SideL)}, x inh{schemaInh_op=(op, SideR)}) of
		 (Nothing, Nothing) -> Nothing
		 (Just f', Nothing) -> Just f'
		 (Nothing, Just x') -> Just x'
		 (Just f', Just x') -> Just $ pairIfNeeded inh op $ f' <> Doc.space <> x'
		where
		op = infixB SideL 10
instance Docable d => Alt (Schema d) where
	lp <!> rp = Schema $ \inh ->
		case (unSchema lp inh, unSchema rp inh) of
		 (Nothing, Nothing) -> Nothing
		 (Just lp', Nothing) -> Just lp'
		 (Nothing, Just rp') -> Just rp'
		 (Just{}, Just{}) -> Just $
			if needsParenInfix (schemaInh_op inh) op
			then
				Doc.breakalt
				 (Doc.parens $
					-- Doc.withBreakable Nothing $
					runSchema lp inh
					 { schemaInh_op=(op, SideL)
					 , schemaInh_or=docOrH } <>
					docOrH <>
					runSchema rp inh
					 { schemaInh_op=(op, SideR)
					 , schemaInh_or=docOrH })
				 (Doc.align $
					Doc.parens $
					Doc.space <>
					runSchema lp inh
					 { schemaInh_op=(op, SideL)
					 , schemaInh_or=docOrV } <>
					docOrV <>
					runSchema rp inh
					 { schemaInh_op=(op, SideR)
					 , schemaInh_or=docOrV } <>
					Doc.newline)
			else
				runSchema lp inh{schemaInh_op=(op, SideL)} <>
				schemaInh_or inh <>
				runSchema rp 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 Pro (Schema d) where
	dimap _a2b _b2a = coerceSchema
instance Docable d => AltApp (Schema d) where
	many0 s = Schema $ \inh -> Just $
		runSchema s inh{schemaInh_op=(op, SideL)}<>"*"
		where op = infixN 10
	many1 s = Schema $ \inh -> Just $
		runSchema s inh{schemaInh_op=(op, SideL)}<>"..."
		where op = infixN 10
instance Docable d => CLI_Command (Schema d) where
	-- type CommandConstraint (Schema d) a = ()
	command n s = Schema $ \inh -> Just $
		if schemaInh_define inh || List.null n
		then
			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 Docable d => CLI_Var (Schema d) where
	type VarConstraint (Schema d) a = ()
	var' n = Schema $ \_inh -> Just $
		Doc.underline $ Doc.from $ Doc.Word n
	just _  = Schema $ \_inh -> Nothing
	nothing = Schema $ \_inh -> Nothing
instance Docable d => CLI_Env (Schema d) where
	type EnvConstraint (Schema d) a = ()
	env' _n = Schema $ \_inh -> Nothing
	 -- NOTE: environment variables are not shown in the schema,
	 -- only in the help.
instance Docable d => CLI_Tag (Schema d) where
	type TagConstraint (Schema d) a = ()
	tagged 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 Docable 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 Docable 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

-- ** Type 'SchemaPerm'
data SchemaPerm d k a = SchemaPerm
 { schemaPerm_finalizer    :: forall b c. Schema d (b->c) c -> Schema d (b->c) c
   -- ^ Used to implement 'rule'.
 , schemaPerm_alternatives :: [Schema d (a->k) k]
   -- ^ Collect alternatives for rendering them all at once in 'runPermutation'.
 }
instance Functor (SchemaPerm d k) where
	_f`fmap`SchemaPerm w ps = SchemaPerm w (coerceSchema <$> ps)
instance Applicative (SchemaPerm d k) where
	pure _a = SchemaPerm id mempty
	SchemaPerm fd w <*> SchemaPerm fx x =
		SchemaPerm (fd . fx) $ (coerceSchema <$> w) <> (coerceSchema <$> x)
instance Docable d => Permutable (Schema d) where
	type Permutation (Schema d) = SchemaPerm d
	runPermutation (SchemaPerm w ps) =
		case ps of
		 [] -> w $ Schema $ \_inh -> Nothing
		 [Schema s] -> w $ Schema s
		 _ -> w $ Schema $ \inh -> Just $
			-- pairIfNeeded inh op $
			Doc.align $
			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.breakalt
			 (Doc.brackets $
				-- Doc.withBreakable Nothing $
				runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH})
			 (Doc.align $
				Doc.brackets $
				Doc.space <>
				runSchema s inh{schemaInh_op=(op, SideL)} <>
				Doc.newline)
		else
			runSchema s inh{schemaInh_op=(op, SideL)}
		where op = infixN0
instance Docable d => CLI_Help (SchemaPerm d) where
	type HelpConstraint (SchemaPerm d) d' = d ~ d'
	help _msg = id
	program n (SchemaPerm w ps) = SchemaPerm (program n . w) ps
	rule n (SchemaPerm w ps) = SchemaPerm (rule n . w) ps