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         element n (Writer w) = Writer $ \rm po pp ->
  58                 pairInfix pp po op $
  59                 "element \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
  60                 where op = infixN 10
  61         anyElem (($ "") -> Writer w) = Writer $ \rm po pp ->
  62                 pairInfix pp po op $
  63                 "any "<>w rm (op,SideR) PairBrace
  64                 where op = infixN 10
  65         attribute n (Writer w) = Writer $ \rm po pp ->
  66                 pairInfix pp po op $
  67                 "attribute \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
  68                 where op = infixN 10
  69         try w   = w
  70         comment = writeText "comment"
  71         text    = writeText "text"
  72         none    = writeText "empty"
  73         any     = writeText "any"
  74         int     = writeText "xsd:int"
  75         nat     = writeText "xsd:nat"
  76         nat1    = writeText "xsd:nat1"
  77         -- anyElem r = Writer $ \_rm _po -> "empty"
  78
  79         Writer wl <|> Writer wr = Writer $ \rm po pp ->
  80                 pairInfix pp po op $
  81                 wl rm (op, SideL) PairParen <> " | " <> wr rm (op, SideR) PairParen
  82                 where op = infixB SideL 2
  83         choice [] = writeText "empty"
  84         choice [w] = w
  85         choice l@(_:_) = Writer $ \rm po pp ->
  86                 pairInfix pp po op $
  87                 Text.intercalate " | " $
  88                 (unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
  89                 where op = infixB SideL 2
  90         many (Writer w) = Writer $ \rm po pp ->
  91                 pairInfix pp po op $
  92                 w rm (op, SideL) PairParen <> "*"
  93                 where op = infixN 10
  94         some (Writer w) = Writer $ \rm po pp ->
  95                 pairInfix pp po op $
  96                 w rm (op, SideL) PairParen <> "+"
  97                 where op = infixN 10
  98         option _x (Writer w) = Writer $ \rm po pp ->
  99                 pairInfix pp po op $
 100                 w rm (op, SideL) PairParen <> "?"
 101                 where op = infixN 10
 102         optional (Writer w) = Writer $ \rm po pp ->
 103                 pairInfix pp po op $
 104                 w rm (op, SideL) PairParen <> "?"
 105                 where op = infixN 10
 106
 107 -- | Get textual rendition of given 'Writer'.
 108 runWriter :: Writer a -> Text
 109 runWriter (Writer w) = w RuleMode_Body (infixN0, SideL) PairParen
 110
 111 -- | Get textual rendition of given 'RuleWriter'.
 112 renderWriter :: RuleWriter a -> Text
 113 renderWriter = runWriter . unRuleWriter
 114
 115 -- | 'Writer' returns a constant rendition.
 116 writeText :: Text -> Writer a
 117 writeText t = Writer $ \_rm _op _pp -> t
 118
 119 -- ** Type 'RuleMode'
 120 data RuleMode
 121  =   RuleMode_Body -- ^ Request to generate the body of the rule.
 122  |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.
 123  deriving (Eq, Show)
 124
 125 -- * Type 'RuleWriter'
 126 newtype RuleWriter a = RuleWriter { unRuleWriter :: Writer a }
 127  deriving (Functor, Applicative)
 128 instance Sym_Rule RuleWriter where
 129         rule n = ruleWriter (writeText n)
 130 deriving instance Sym_RuleWriter RuleWriter
 131 type instance Perm RuleWriter = Compose [] RuleWriter
 132 instance Sym_Interleaved RuleWriter where
 133         interleaved (Compose l)          = RuleWriter $ interleaved $ Compose $ unRuleWriter <$> l
 134         f <$$> RuleWriter w              = Compose $ (RuleWriter <$>) $ getCompose $ f <$$> w
 135         f <$?> (a,RuleWriter w)          = Compose $ (RuleWriter <$>) $ getCompose $ f <$?> (a,w)
 136         f <$*> RuleWriter w              = Compose $ (RuleWriter <$>) $ getCompose $ f <$*> w
 137         Compose ws <||> RuleWriter w     = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <||> w
 138         Compose ws <|?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|?> (a,w)
 139         Compose ws <|*> RuleWriter w     = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|*> w
 140 deriving instance Sym_RNC RuleWriter
 141
 142 -- ** Class 'Sym_RuleWriter'
 143 -- | Symantics for rendering 'Writer' rules.
 144 --
 145 -- * 'ruleWriter' renders a rule, either its body or a reference to it, according to 'RuleMode'.
 146 -- * 'argWriter' renders an argument.
 147 class Sym_RuleWriter g where
 148         ruleWriter :: Writer () -> g a -> RuleWriter a
 149         argWriter  :: Text -> g a
 150 instance Sym_RuleWriter Writer where
 151         argWriter = writeText
 152         ruleWriter call body =
 153                 RuleWriter $ Writer $ \rm po pp ->
 154                         case rm of
 155                          RuleMode_Ref -> unWriter call rm po pp
 156                          RuleMode_Body ->
 157                                 Text.intercalate " "
 158                                  [ unWriter call RuleMode_Ref (infixN0,SideL) pp
 159                                  , "="
 160                                  , unWriter body RuleMode_Ref (infixN0,SideR) pp
 161                                  ]