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