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 => SchemaDoc d => Schema d f k -> d
docSchema s = runSchema s defSchemaInh

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

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

-- ** 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 :: 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 => Functor (Schema d f) where
	_f `fmap` Schema x = Schema $ \inh ->
		pairIfNeeded (schemaInh_op inh) op <$>
		x inh{schemaInh_op=(op, SideR)}
		where
		op = infixB SideL 10
-}
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 ->
		-- NOTE: first try to see if both sides are 'Just',
		-- otherwise does not change the inherited operator context.
		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
				-- NOTE: when parenthesis are needed
				-- first try to fit the alternative on a single line,
				-- otherwise align them on multiple lines.
				Doc.breakalt
				 (Doc.parens $
					-- Doc.withBreakable Nothing $
					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
				-- NOTE: when parenthesis are NOT needed
				-- just concat alternatives using the inherited separator
				-- (either horizontal or vertical).
				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
	-- type CommandConstraint (Schema d) a = ()
	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
	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
	 -- NOTE: environment variables are not shown in the schema,
	 -- only in the help.
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

-- ** Type 'SchemaSeq'
data SchemaSeq d k a = SchemaSeq
 { schemaSeq_finalizer :: forall b c.
                           Schema d (b->c) c ->
                           Schema d (b->c) c
   -- ^ Used to implement 'rule'.
 , schemaSeq_alternatives :: [Schema d (a->k) k]
   -- ^ Collect alternatives for rendering them all at once in 'runSequence'.
 }
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

-- ** 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 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