Sym.hs

{-# LANGUAGE TypeFamilyDependencies #-}
module Symantic.RNC.Sym
 ( module 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 Symantic.XML as XML

-- * Class 'Sym_RNC'
class
 ( Applicative repr
 , Alternative repr
 , Sym_Rule repr
 , Sym_Permutation repr
 ) => Sym_RNC repr where
	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
	escapedText :: repr XML.EscapedText
	text        :: repr TL.Text
	text = XML.unescapeText <$> escapedText
	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

-- * Class 'Sym_Rule'
class Sym_Rule repr where
	rule :: Show a => String -> repr a -> repr a
	rule _n = id
	arg :: String -> repr ()

-- ** 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_Permutation'
class (Alternative repr, Applicative (Permutation repr)) => Sym_Permutation repr where
	runPermutation :: Permutation repr a -> repr a
	toPermutation :: repr a -> Permutation repr a
	toPermutationWithDefault :: a -> repr a -> Permutation repr a
	
	(<$$>) :: (a -> b) -> repr a -> Permutation repr b
	(<$?>) :: (a -> b) -> (a, repr a) -> Permutation repr b
	(<$*>) :: ([a] -> b) -> repr a -> Permutation repr b
	(<$:>) :: (Seq a -> b) -> repr a -> Permutation repr b
	infixl 2 <$$>, <$?>, <$*>, <$:>
	{-# INLINE (<$$>) #-}
	{-# INLINE (<$?>) #-}
	{-# INLINE (<$*>) #-}
	{-# INLINE (<$:>) #-}
	
	(<||>) :: Permutation repr (a -> b) -> repr a -> Permutation repr b
	(<|?>) :: Permutation repr (a -> b) -> (a, repr a) -> Permutation repr b
	(<|*>) :: Permutation repr ([a] -> b) -> repr a -> Permutation repr b
	(<|:>) :: Permutation repr (Seq a -> b) -> repr a -> Permutation repr b
	infixl 1 <||>, <|?>, <|*>, <|:>
	{-# INLINE (<||>) #-}
	{-# INLINE (<|?>) #-}
	{-# INLINE (<|*>) #-}
	{-# INLINE (<|:>) #-}
	
	f <$$> x = f <$> toPermutation x
	f <$?> (d,x) = f <$> toPermutationWithDefault d x
	f <$*> x = f <$> toPermutationWithDefault [] (some x)
	f <$:> x = f . Seq.fromList <$> toPermutationWithDefault [] (some x)
	
	f <||> x = f <*> toPermutation x
	f <|?> (d,x) = f <*> toPermutationWithDefault d x
	f <|*> x = f <*> toPermutationWithDefault [] (some x)
	f <|:> x = f <*> toPermutationWithDefault Seq.empty (Seq.fromList <$> some x)

-- ** Type family 'Permutation'
-- | Type of permutations, depending on the representation.
type family Permutation (repr:: * -> *) = (r :: * -> *) | r -> repr