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