{-# LANGUAGE TypeFamilyDependencies #-}
module Language.Symantic.RNC.Sym
 ( module Language.Symantic.RNC.Sym
 , Functor(..), (<$>)
 , Applicative(..)
 , Alternative(..)
 ) where

import Control.Applicative (Applicative(..), Alternative(..))
import Data.Eq (Eq)
import Data.Function ((.), id)
import Data.Functor (Functor(..), (<$>))
import Data.Maybe (Maybe(..))
import Data.Sequence (Seq)
import Data.String (String)
import Text.Show (Show(..))
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL

import qualified Language.Symantic.XML as XML

infixl 2 <$$>, <$?>, <$*>, <$:>
infixl 1 <||>, <|?>, <|*>{-, <|:>-}

-- * Class 'Sym_RNC'
class
 ( Applicative repr
 , Alternative repr
 , Sym_Rule repr
 , Sym_Interleaved repr
 ) => Sym_RNC repr where
	-- namespace :: XML.NCName -> XML.Namespace -> repr ()
	namespace :: Maybe XML.NCName -> XML.Namespace -> repr ()
	element   :: XML.QName -> repr a -> repr a
	attribute :: XML.QName -> repr a -> repr a
	any       :: repr ()
	anyElem   :: XML.Namespace -> (XML.NCName -> repr a) -> repr a
	text      :: repr TL.Text
	fail      :: repr a
	try       :: repr a -> repr a
	option    :: a -> repr a -> repr a
	optional  :: repr a -> repr (Maybe a)
	choice    :: [repr a] -> repr a
	intermany :: [repr a] -> repr [a]
	intermany = many . choice . (try <$>)
	manySeq :: repr a -> repr (Seq a)
	manySeq r = Seq.fromList <$> many r
	someSeq :: repr a -> repr (Seq a)
	someSeq r = Seq.fromList <$> some r
{-
instance (Sym_RNC x, Sym_RNC y) => Sym_RNC (Dup x y) where
	namespace n ns = dup0 @Sym_RNC (namespace n ns)
	element   n = dup1 @Sym_RNC (element n)
	attribute n = dup1 @Sym_RNC (attribute n)
	any     = dup0 @Sym_RNC any
	anyElem ns f =
		anyElem ns (\n -> let x`Dup`_y = f n in x)
		`Dup`
		anyElem ns (\n -> let _x`Dup`y = f n in y)
	text    = dup0 @Sym_RNC text
	fail    = dup0 @Sym_RNC fail
	try = dup1 @Sym_RNC try
	option d = dup1 @Sym_RNC (option d)
	optional = dup1 @Sym_RNC optional
	choice cs = choice xs `Dup` choice ys
		where (xs,ys) = dupList cs
	intermany cs = intermany xs `Dup` intermany ys
		where (xs,ys) = dupList cs
	manySeq = dup1 @Sym_RNC manySeq
	someSeq = dup1 @Sym_RNC someSeq
deriving instance (Sym_RNC repr, Sym_Rule repr) => Sym_RNC (Rule repr)
-}

-- * Class 'Sym_Rule'
class Sym_Rule repr where
	rule :: Show a => String -> repr a -> repr a
	rule _n = id
	arg :: String -> repr ()
{-
instance (Sym_Rule x, Sym_Rule y) => Sym_Rule (Dup x y) where
	rule n = dup1 @Sym_Rule (rule n)
	arg n  = dup0 @Sym_Rule (arg n)
-}

-- ** Type 'RuleMode'
data RuleMode
 =   RuleMode_Body -- ^ Request to generate the body of the rule.
 |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.
 |   RuleMode_Def  -- ^ Request to generate a definition of the rule.
 deriving (Eq, Show)

-- * Class 'Sym_Interleaved'
class Sym_Interleaved repr where
	interleaved :: Perm repr a -> repr a
	(<$$>) :: (a -> b) -> repr a -> Perm repr b
	
	(<$?>) :: (a -> b) -> (a, repr a) -> Perm repr b
	(<||>) :: Perm repr (a -> b) -> repr a -> Perm repr b
	(<|?>) :: Perm repr (a -> b) -> (a, repr a) -> Perm repr b
	
	(<$*>) :: ([a] -> b) -> repr a -> Perm repr b
	(<|*>) :: Perm repr ([a] -> b) -> repr a -> Perm repr b
	
	(<$:>) :: (Seq a -> b) -> repr a -> Perm repr b
	(<$:>) f = (f . Seq.fromList <$*>)
	{- NOTE: Megaparsec's PermParser has no Functor instance.
	(<|:>) :: Perm repr (Seq a -> b) -> repr a -> Perm repr b
	default (<|:>) :: Functor (Perm repr) => Perm repr (Seq a -> b) -> repr a -> Perm repr b
	(<|:>) f x = (. Seq.fromList) <$> f <|*> x
	-}
{-
instance (Sym_Interleaved x, Sym_Interleaved y) => Sym_Interleaved (Dup x y) where
	interleaved (x`Dup`y)             = interleaved x    `Dup` interleaved y
	(<$$>) f (x`Dup`y)                = (<$$>) f x       `Dup` (<$$>) f y
	(<$?>) f (a, x`Dup`y)             = (<$?>) f (a,x)   `Dup` (<$?>) f (a,y)
	(<||>) (x1`Dup`y1) (x2`Dup`y2)    = (<||>) x1 x2     `Dup` (<||>) y1 y2
	(<|?>) (x1`Dup`y1) (a, x2`Dup`y2) = (<|?>) x1 (a,x2) `Dup` (<|?>) y1 (a,y2)
	(<$*>) f (x`Dup`y)                = (<$*>) f x       `Dup` (<$*>) f y
	(<|*>) (x1`Dup`y1) (x2`Dup`y2)    = (<|*>) x1 x2     `Dup` (<|*>) y1 y2
	(<$:>) f (x`Dup`y)                = (<$:>) f x       `Dup` (<$:>) f y
	{-
	(<|:>) (x1`Dup`y1) (x2`Dup`y2)    = (<|:>) x1 x2     `Dup` (<|:>) y1 y2
	-}
-}
{-
instance Sym_Interleaved repr => Sym_Interleaved (Rule repr) where
	interleaved = Rule . interleaved . unRule
	f <$$> Rule w           = Rule $ f <$$> w
	f <$?> (d, Rule w)      = Rule $ f <$?> (d, w)
	f <$*> Rule w           = Rule $ f <$*> w
	f <$:> Rule w           = Rule $ f <$:> w
	Rule f <||> Rule x      = Rule $ f <||> x
	Rule f <|?> (d, Rule x) = Rule $ f <|?> (d, x)
	Rule f <|*> Rule x      = Rule $ f <|*> x
-}
{-
	interleaved (Compose l)    = Rule $ interleaved $ Compose $ unRule <$> l
	f <$$> Rule w              = Compose $ (Rule <$>) $ getCompose $ f <$$> w
	f <$?> (a,Rule w)          = Compose $ (Rule <$>) $ getCompose $ f <$?> (a,w)
	f <$*> Rule w              = Compose $ (Rule <$>) $ getCompose $ f <$*> w
	Compose ws <||> Rule w     = Compose $ (Rule <$>) $ getCompose $ Compose (unRule <$> ws) <||> w
	Compose ws <|?> (a,Rule w) = Compose $ (Rule <$>) $ getCompose $ Compose (unRule <$> ws) <|?> (a,w)
	Compose ws <|*> Rule w     = Compose $ (Rule <$>) $ getCompose $ Compose (unRule <$> ws) <|*> w
-}

-- ** Type family 'Perm'
-- | Type of permutations, depending on the representation.
type family Perm (repr:: * -> *) = (r :: * -> *) | r -> repr
-- type instance Perm (Dup x y) = Dup (Perm x) (Perm y)
-- type instance Perm (Rule repr) = Rule (Perm repr) -- Compose [] (Rule (Perm repr))