Language/RNC/Write.hs

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