Language/Symantic/RNC/Sym.hs

   1 {-# LANGUAGE TypeFamilyDependencies #-}
   2 module Language.Symantic.RNC.Sym
   3  ( module Language.Symantic.RNC.Sym
   4  , Functor(..), (<$>)
   5  , Applicative(..)
   6  , Alternative(..)
   7  ) where
   8
   9 import Control.Applicative (Applicative(..), Alternative(..))
  10 import Data.Eq (Eq)
  11 import Data.Function ((.), id)
  12 import Data.Functor (Functor(..), (<$>))
  13 import Data.Maybe (Maybe(..))
  14 import Data.Sequence (Seq)
  15 import Data.String (String)
  16 import Text.Show (Show(..))
  17 import qualified Data.Sequence as Seq
  18 import qualified Data.Text.Lazy as TL
  19
  20 import qualified Language.Symantic.XML as XML
  21
  22 infixl 2 <$$>, <$?>, <$*>, <$:>
  23 infixl 1 <||>, <|?>, <|*>{-, <|:>-}
  24
  25 -- * Class 'Sym_RNC'
  26 class
  27  ( Applicative repr
  28  , Alternative repr
  29  , Sym_Rule repr
  30  , Sym_Interleaved repr
  31  ) => Sym_RNC repr where
  32         -- namespace :: XML.NCName -> XML.Namespace -> repr ()
  33         namespace :: Maybe XML.NCName -> XML.Namespace -> repr ()
  34         element   :: XML.QName -> repr a -> repr a
  35         attribute :: XML.QName -> repr a -> repr a
  36         any       :: repr ()
  37         anyElem   :: XML.Namespace -> (XML.NCName -> repr a) -> repr a
  38         text      :: repr TL.Text
  39         fail      :: repr a
  40         try       :: repr a -> repr a
  41         option    :: a -> repr a -> repr a
  42         optional  :: repr a -> repr (Maybe a)
  43         choice    :: [repr a] -> repr a
  44         intermany :: [repr a] -> repr [a]
  45         intermany = many . choice . (try <$>)
  46         manySeq :: repr a -> repr (Seq a)
  47         manySeq r = Seq.fromList <$> many r
  48         someSeq :: repr a -> repr (Seq a)
  49         someSeq r = Seq.fromList <$> some r
  50 {-
  51 instance (Sym_RNC x, Sym_RNC y) => Sym_RNC (Dup x y) where
  52         namespace n ns = dup0 @Sym_RNC (namespace n ns)
  53         element   n = dup1 @Sym_RNC (element n)
  54         attribute n = dup1 @Sym_RNC (attribute n)
  55         any     = dup0 @Sym_RNC any
  56         anyElem ns f =
  57                 anyElem ns (\n -> let x`Dup`_y = f n in x)
  58                 `Dup`
  59                 anyElem ns (\n -> let _x`Dup`y = f n in y)
  60         text    = dup0 @Sym_RNC text
  61         fail    = dup0 @Sym_RNC fail
  62         try = dup1 @Sym_RNC try
  63         option d = dup1 @Sym_RNC (option d)
  64         optional = dup1 @Sym_RNC optional
  65         choice cs = choice xs `Dup` choice ys
  66                 where (xs,ys) = dupList cs
  67         intermany cs = intermany xs `Dup` intermany ys
  68                 where (xs,ys) = dupList cs
  69         manySeq = dup1 @Sym_RNC manySeq
  70         someSeq = dup1 @Sym_RNC someSeq
  71 deriving instance (Sym_RNC repr, Sym_Rule repr) => Sym_RNC (Rule repr)
  72 -}
  73
  74 -- * Class 'Sym_Rule'
  75 class Sym_Rule repr where
  76         rule :: Show a => String -> repr a -> repr a
  77         rule _n = id
  78         arg :: String -> repr ()
  79 {-
  80 instance (Sym_Rule x, Sym_Rule y) => Sym_Rule (Dup x y) where
  81         rule n = dup1 @Sym_Rule (rule n)
  82         arg n  = dup0 @Sym_Rule (arg n)
  83 -}
  84
  85 -- ** Type 'RuleMode'
  86 data RuleMode
  87  =   RuleMode_Body -- ^ Request to generate the body of the rule.
  88  |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.
  89  |   RuleMode_Def  -- ^ Request to generate a definition of the rule.
  90  deriving (Eq, Show)
  91
  92 -- * Class 'Sym_Interleaved'
  93 class Sym_Interleaved repr where
  94         interleaved :: Perm repr a -> repr a
  95         (<$$>) :: (a -> b) -> repr a -> Perm repr b
  96
  97         (<$?>) :: (a -> b) -> (a, repr a) -> Perm repr b
  98         (<||>) :: Perm repr (a -> b) -> repr a -> Perm repr b
  99         (<|?>) :: Perm repr (a -> b) -> (a, repr a) -> Perm repr b
 100
 101         (<$*>) :: ([a] -> b) -> repr a -> Perm repr b
 102         (<|*>) :: Perm repr ([a] -> b) -> repr a -> Perm repr b
 103
 104         (<$:>) :: (Seq a -> b) -> repr a -> Perm repr b
 105         (<$:>) f = (f . Seq.fromList <$*>)
 106         {- NOTE: Megaparsec's PermParser has no Functor instance.
 107         (<|:>) :: Perm repr (Seq a -> b) -> repr a -> Perm repr b
 108         default (<|:>) :: Functor (Perm repr) => Perm repr (Seq a -> b) -> repr a -> Perm repr b
 109         (<|:>) f x = (. Seq.fromList) <$> f <|*> x
 110         -}
 111 {-
 112 instance (Sym_Interleaved x, Sym_Interleaved y) => Sym_Interleaved (Dup x y) where
 113         interleaved (x`Dup`y)             = interleaved x    `Dup` interleaved y
 114         (<$$>) f (x`Dup`y)                = (<$$>) f x       `Dup` (<$$>) f y
 115         (<$?>) f (a, x`Dup`y)             = (<$?>) f (a,x)   `Dup` (<$?>) f (a,y)
 116         (<||>) (x1`Dup`y1) (x2`Dup`y2)    = (<||>) x1 x2     `Dup` (<||>) y1 y2
 117         (<|?>) (x1`Dup`y1) (a, x2`Dup`y2) = (<|?>) x1 (a,x2) `Dup` (<|?>) y1 (a,y2)
 118         (<$*>) f (x`Dup`y)                = (<$*>) f x       `Dup` (<$*>) f y
 119         (<|*>) (x1`Dup`y1) (x2`Dup`y2)    = (<|*>) x1 x2     `Dup` (<|*>) y1 y2
 120         (<$:>) f (x`Dup`y)                = (<$:>) f x       `Dup` (<$:>) f y
 121         {-
 122         (<|:>) (x1`Dup`y1) (x2`Dup`y2)    = (<|:>) x1 x2     `Dup` (<|:>) y1 y2
 123         -}
 124 -}
 125 {-
 126 instance Sym_Interleaved repr => Sym_Interleaved (Rule repr) where
 127         interleaved = Rule . interleaved . unRule
 128         f <$$> Rule w           = Rule $ f <$$> w
 129         f <$?> (d, Rule w)      = Rule $ f <$?> (d, w)
 130         f <$*> Rule w           = Rule $ f <$*> w
 131         f <$:> Rule w           = Rule $ f <$:> w
 132         Rule f <||> Rule x      = Rule $ f <||> x
 133         Rule f <|?> (d, Rule x) = Rule $ f <|?> (d, x)
 134         Rule f <|*> Rule x      = Rule $ f <|*> x
 135 -}
 136 {-
 137         interleaved (Compose l)    = Rule $ interleaved $ Compose $ unRule <$> l
 138         f <$$> Rule w              = Compose $ (Rule <$>) $ getCompose $ f <$$> w
 139         f <$?> (a,Rule w)          = Compose $ (Rule <$>) $ getCompose $ f <$?> (a,w)
 140         f <$*> Rule w              = Compose $ (Rule <$>) $ getCompose $ f <$*> w
 141         Compose ws <||> Rule w     = Compose $ (Rule <$>) $ getCompose $ Compose (unRule <$> ws) <||> w
 142         Compose ws <|?> (a,Rule w) = Compose $ (Rule <$>) $ getCompose $ Compose (unRule <$> ws) <|?> (a,w)
 143         Compose ws <|*> Rule w     = Compose $ (Rule <$>) $ getCompose $ Compose (unRule <$> ws) <|*> w
 144 -}
 145
 146 -- ** Type family 'Perm'
 147 -- | Type of permutations, depending on the representation.
 148 type family Perm (repr:: * -> *) = (r :: * -> *) | r -> repr
 149 -- type instance Perm (Dup x y) = Dup (Perm x) (Perm y)
 150 -- type instance Perm (Rule repr) = Rule (Perm repr) -- Compose [] (Rule (Perm repr))
 151