{-# 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