Language/RNC/Write.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE StandaloneDeriving #-}
   3 {-# LANGUAGE TypeFamilies #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 module Language.RNC.Write where
   6
   7 import Control.Applicative (Applicative(..))
   8 import Control.Monad
   9 import Data.Functor.Compose (Compose(..))
  10 import Data.Semigroup hiding (option)
  11 import Data.Text (Text)
  12 import Prelude hiding (any)
  13 import qualified Data.Text as Text
  14
  15 import Language.RNC.Sym
  16 import Language.RNC.Fixity
  17
  18 -- * Type 'Writer'
  19 newtype Writer a
  20  =      Writer { unWriter :: RuleMode -> (Infix, Side) -> Pair -> Text }
  21
  22 instance Show (Writer a) where
  23         show = Text.unpack . runWriter
  24 instance Functor Writer where
  25         fmap _f (Writer x) = Writer x
  26 instance Applicative Writer where
  27         pure _ = writeText $ "\"\""
  28         Writer f <*> Writer x = Writer $ \rm po pp ->
  29                 pairInfix pp po op $
  30                 f rm (op, SideL) pp <> ", " <> x rm (op, SideR) pp
  31                 where op = infixB SideL 10
  32 instance Sym_Rule Writer where
  33         rule n (Writer w) = Writer $ \rm po pp ->
  34                 case rm of
  35                  RuleMode_Body -> w RuleMode_Ref po pp
  36                  RuleMode_Ref  -> n
  37 type instance Perm Writer = Compose [] Writer
  38 instance Sym_Interleaved Writer where
  39         interleaved (Compose []) = writeText "empty"
  40         interleaved (Compose [Writer w]) = Writer w
  41         interleaved (Compose l@(_:_)) = Writer $ \rm po pp ->
  42                 pairInfix pp po op $
  43                 Text.intercalate " & " $
  44                 (unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
  45                 where op = infixB SideL 2
  46         _f <$$> Writer w         = Compose [Writer w]
  47         _f <$?> (_,Writer w)     = Compose [Writer $ unWriter $ optional $ Writer w]
  48         _f <$*> Writer w         = Compose [Writer $ unWriter $ many (Writer w)]
  49         Compose ws <||> Writer w = Compose (Writer . unWriter <$> ws <> [Writer w])
  50         Compose ws <|?> (_,Writer w) =
  51                 Compose ((Writer . unWriter <$> ws) <>
  52                 [Writer $ unWriter $ optional $ Writer w])
  53         Compose ws <|*> (Writer w) =
  54                 Compose (Writer . unWriter <$> ws <>
  55                 [Writer $ unWriter $ many $ Writer w])
  56 instance Sym_RNC Writer where
  57         position (Writer w) = Writer w
  58         element n (Writer w) = Writer $ \rm po pp ->
  59                 pairInfix pp po op $
  60                 "element \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
  61                 where op = infixN 10
  62         anyElem (($ "") -> Writer w) = Writer $ \rm po pp ->
  63                 pairInfix pp po op $
  64                 "any "<>w rm (op,SideR) PairBrace
  65                 where op = infixN 10
  66         attribute n (Writer w) = Writer $ \rm po pp ->
  67                 pairInfix pp po op $
  68                 "attribute \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
  69                 where op = infixN 10
  70         try w   = w
  71         comment = writeText "comment"
  72         text    = writeText "text"
  73         none    = writeText "empty"
  74         any     = writeText "any"
  75         int     = writeText "xsd:int"
  76         nat     = writeText "xsd:nat"
  77         nat1    = writeText "xsd:nat1"
  78         -- anyElem r = Writer $ \_rm _po -> "empty"
  79
  80         Writer wl <|> Writer wr = Writer $ \rm po pp ->
  81                 pairInfix pp po op $
  82                 wl rm (op, SideL) PairParen <> " | " <> wr rm (op, SideR) PairParen
  83                 where op = infixB SideL 2
  84         choice [] = writeText "empty"
  85         choice [w] = w
  86         choice l@(_:_) = Writer $ \rm po pp ->
  87                 pairInfix pp po op $
  88                 Text.intercalate " | " $
  89                 (unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
  90                 where op = infixB SideL 2
  91         many (Writer w) = Writer $ \rm po pp ->
  92                 pairInfix pp po op $
  93                 w rm (op, SideL) PairParen <> "*"
  94                 where op = infixN 10
  95         some (Writer w) = Writer $ \rm po pp ->
  96                 pairInfix pp po op $
  97                 w rm (op, SideL) PairParen <> "+"
  98                 where op = infixN 10
  99         option _x (Writer w) = Writer $ \rm po pp ->
 100                 pairInfix pp po op $
 101                 w rm (op, SideL) PairParen <> "?"
 102                 where op = infixN 10
 103         optional (Writer w) = Writer $ \rm po pp ->
 104                 pairInfix pp po op $
 105                 w rm (op, SideL) PairParen <> "?"
 106                 where op = infixN 10
 107
 108 -- | Get textual rendition of given 'Writer'.
 109 runWriter :: Writer a -> Text
 110 runWriter (Writer w) = w RuleMode_Body (infixN0, SideL) PairParen
 111
 112 -- | Get textual rendition of given 'RuleWriter'.
 113 renderWriter :: RuleWriter a -> Text
 114 renderWriter = runWriter . unRuleWriter
 115
 116 -- | 'Writer' returns a constant rendition.
 117 writeText :: Text -> Writer a
 118 writeText t = Writer $ \_rm _op _pp -> t
 119
 120 -- ** Type 'RuleMode'
 121 data RuleMode
 122  =   RuleMode_Body -- ^ Request to generate the body of the rule.
 123  |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.
 124  deriving (Eq, Show)
 125
 126 -- * Type 'RuleWriter'
 127 newtype RuleWriter a = RuleWriter { unRuleWriter :: Writer a }
 128  deriving (Functor, Applicative)
 129 instance Sym_Rule RuleWriter where
 130         rule n = ruleWriter (writeText n)
 131 deriving instance Sym_RuleWriter RuleWriter
 132 type instance Perm RuleWriter = Compose [] RuleWriter
 133 instance Sym_Interleaved RuleWriter where
 134         interleaved (Compose l)          = RuleWriter $ interleaved $ Compose $ unRuleWriter <$> l
 135         f <$$> RuleWriter w              = Compose $ (RuleWriter <$>) $ getCompose $ f <$$> w
 136         f <$?> (a,RuleWriter w)          = Compose $ (RuleWriter <$>) $ getCompose $ f <$?> (a,w)
 137         f <$*> RuleWriter w              = Compose $ (RuleWriter <$>) $ getCompose $ f <$*> w
 138         Compose ws <||> RuleWriter w     = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <||> w
 139         Compose ws <|?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|?> (a,w)
 140         Compose ws <|*> RuleWriter w     = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|*> w
 141 deriving instance Sym_RNC RuleWriter
 142
 143 -- ** Class 'Sym_RuleWriter'
 144 -- | Symantics for rendering 'Writer' rules.
 145 --
 146 -- * 'ruleWriter' renders a rule, either its body or a reference to it, according to 'RuleMode'.
 147 -- * 'argWriter' renders an argument.
 148 class Sym_RuleWriter g where
 149         ruleWriter :: Writer () -> g a -> RuleWriter a
 150         argWriter  :: Text -> g a
 151 instance Sym_RuleWriter Writer where
 152         argWriter = writeText
 153         ruleWriter call body =
 154                 RuleWriter $ Writer $ \rm po pp ->
 155                         case rm of
 156                          RuleMode_Ref -> unWriter call rm po pp
 157                          RuleMode_Body ->
 158                                 Text.intercalate " "
 159                                  [ unWriter call RuleMode_Ref (infixN0,SideL) pp
 160                                  , "="
 161                                  , unWriter body RuleMode_Ref (infixN0,SideR) pp
 162                                  ]