Language/DTC/RNC.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 module Language.DTC.RNC where
   3
   4 import Control.Applicative (Applicative(..))
   5 import Control.Monad
   6 import Data.Semigroup hiding (option)
   7 import Data.String (IsString(..))
   8 import Data.Text (Text)
   9 import Prelude hiding (any)
  10 import qualified Data.Bool as Bool
  11 import qualified Data.Text as Text
  12
  13 -- * Type 'RNC'
  14 -- | Relax NG Compact
  15 newtype RNC a = RNC { unRNC :: RuleMode -> (Infix, Side) -> Text }
  16 instance Show (RNC a) where
  17         show = Text.unpack . runRNC
  18 instance Functor RNC where
  19         fmap _f (RNC x) = RNC x
  20 instance Applicative RNC where
  21         pure _ = rnc_const $ "\"\""
  22         RNC f <*> RNC x = RNC $ \bo po -> parenInfix po op $
  23                 f bo (op, SideL) <> ", " <> x bo (op, SideR)
  24                 where op = infixB SideL 10
  25
  26 -- ** Class 'Sym_Rule'
  27 class Sym_Rule g where
  28         rule :: Text -> Rule (g a)
  29         rule _n = id
  30 instance Sym_Rule RuleRNC where
  31         rule n = ruleRNC (rnc_const n)
  32 instance Sym_Rule RNC where
  33         rule n g = RNC $ \rm po ->
  34                 case rm of
  35                  RuleMode_Body -> unRNC g RuleMode_Ref po
  36                  RuleMode_Ref  -> n
  37
  38 -- | Get textual rendition of given 'RNC'.
  39 runRNC :: RNC a -> Text
  40 runRNC (RNC g) = g RuleMode_Body (infixN0, SideL)
  41
  42 -- | Get textual rendition of given 'RuleRNC'.
  43 renderRNC :: RuleRNC a -> Text
  44 renderRNC = runRNC . unRuleRNC
  45
  46 -- | 'RNC' returns a constant rendition.
  47 rnc_const :: Text -> RNC a
  48 rnc_const t = RNC $ \_rm _op -> t
  49
  50 -- ** Type 'RuleMode'
  51 data RuleMode
  52  =   RuleMode_Body -- ^ Request to generate the body of the rule.
  53  |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.
  54  deriving (Eq, Show)
  55
  56 -- * Type 'Rule'
  57 type Rule a = a -> a
  58
  59 -- * Type 'RuleRNC'
  60 newtype RuleRNC a = RuleRNC { unRuleRNC :: RNC a }
  61  deriving (Functor, Applicative)
  62 deriving instance Sym_RuleRNC RuleRNC
  63
  64 -- ** Class 'Sym_RuleRNC'
  65 -- | Symantics for rendering 'RNC' rules.
  66 --
  67 -- * 'ruleRNC' renders a rule, either its body or a reference to it, according to 'RuleMode'.
  68 -- * 'argRNC' renders an argument.
  69 class Sym_RuleRNC g where
  70         ruleRNC :: RNC () -> g a -> RuleRNC a
  71         argRNC  :: Text -> g a
  72 instance Sym_RuleRNC RNC where
  73         argRNC = rnc_const
  74         ruleRNC call body =
  75                 RuleRNC $ RNC $ \mo po ->
  76                         case mo of
  77                          RuleMode_Ref -> unRNC call mo po
  78                          RuleMode_Body ->
  79                                 Text.intercalate " "
  80                                  [ unRNC call RuleMode_Ref (infixN0, SideL)
  81                                  , "="
  82                                  , unRNC body RuleMode_Ref (infixN0, SideR)
  83                                  ]