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