Hdoc/RNC/Write.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE StandaloneDeriving #-}
   3 {-# LANGUAGE TypeFamilies #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE ViewPatterns #-}
   6 module Hdoc.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 Hdoc.RNC.Sym
  23 import Hdoc.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" -- FIXME: is it useful to use the xsd: namespace?
  86         rational = writeText "rational"
  87         rationalPositive = writeText "rationalPositive"
  88         nat      = writeText "nat"
  89         nat1     = writeText "nat1"
  90         -- anyElem r = Writer $ \_rm _po -> "empty"
  91
  92         Writer wl <|> Writer wr = Writer $ \rm po pp ->
  93                 pairInfix pp po op $
  94                 wl rm (op, SideL) PairParen <> " | " <> wr rm (op, SideR) PairParen
  95                 where op = infixB SideL 2
  96         choice [] = writeText "empty"
  97         choice [w] = w
  98         choice l@(_:_) = Writer $ \rm po pp ->
  99                 pairInfix pp po op $
 100                 TL.intercalate " | " $
 101                 (unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
 102                 where op = infixB SideL 2
 103         many (Writer w) = Writer $ \rm po pp ->
 104                 pairInfix pp po op $
 105                 w rm (op, SideL) PairParen <> "*"
 106                 where op = infixN 10
 107         some (Writer w) = Writer $ \rm po pp ->
 108                 pairInfix pp po op $
 109                 w rm (op, SideL) PairParen <> "+"
 110                 where op = infixN 10
 111         option _x (Writer w) = Writer $ \rm po pp ->
 112                 pairInfix pp po op $
 113                 w rm (op, SideL) PairParen <> "?"
 114                 where op = infixN 10
 115         optional (Writer w) = Writer $ \rm po pp ->
 116                 pairInfix pp po op $
 117                 w rm (op, SideL) PairParen <> "?"
 118                 where op = infixN 10
 119
 120 -- | Get textual rendition of given 'Writer'.
 121 runWriter :: Writer a -> TL.Text
 122 runWriter (Writer w) = w RuleMode_Body (infixN0, SideL) PairParen
 123
 124 -- | Get textual rendition of given 'RuleWriter'.
 125 renderWriter :: RuleWriter a -> TL.Text
 126 renderWriter = runWriter . unRuleWriter
 127
 128 -- | 'Writer' returns a constant rendition.
 129 writeText :: TL.Text -> Writer a
 130 writeText t = Writer $ \_rm _op _pp -> t
 131
 132 -- ** Type 'RuleMode'
 133 data RuleMode
 134  =   RuleMode_Body -- ^ Request to generate the body of the rule.
 135  |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.
 136  deriving (Eq, Show)
 137
 138 -- * Type 'RuleWriter'
 139 newtype RuleWriter a = RuleWriter { unRuleWriter :: Writer a }
 140  deriving (Functor, Applicative)
 141 instance Sym_Rule RuleWriter where
 142         rule n = ruleWriter (writeText $ TL.fromStrict n)
 143 deriving instance Sym_RuleWriter RuleWriter
 144 type instance Perm RuleWriter = Compose [] RuleWriter
 145 instance Sym_Interleaved RuleWriter where
 146         interleaved (Compose l)          = RuleWriter $ interleaved $ Compose $ unRuleWriter <$> l
 147         f <$$> RuleWriter w              = Compose $ (RuleWriter <$>) $ getCompose $ f <$$> w
 148         f <$?> (a,RuleWriter w)          = Compose $ (RuleWriter <$>) $ getCompose $ f <$?> (a,w)
 149         f <$*> RuleWriter w              = Compose $ (RuleWriter <$>) $ getCompose $ f <$*> w
 150         Compose ws <||> RuleWriter w     = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <||> w
 151         Compose ws <|?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|?> (a,w)
 152         Compose ws <|*> RuleWriter w     = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|*> w
 153 deriving instance Sym_RNC RuleWriter
 154
 155 -- ** Class 'Sym_RuleWriter'
 156 -- | Symantics for rendering 'Writer' rules.
 157 --
 158 -- * 'ruleWriter' renders a rule, either its body or a reference to it, according to 'RuleMode'.
 159 -- * 'argWriter' renders an argument.
 160 class Sym_RuleWriter g where
 161         ruleWriter :: Writer () -> g a -> RuleWriter a
 162         argWriter  :: Text -> g a
 163 instance Sym_RuleWriter Writer where
 164         argWriter = writeText . TL.fromStrict
 165         ruleWriter call body =
 166                 RuleWriter $ Writer $ \rm po pp ->
 167                         case rm of
 168                          RuleMode_Ref -> unWriter call rm po pp
 169                          RuleMode_Body ->
 170                                 TL.intercalate " "
 171                                  [ unWriter call RuleMode_Ref (infixN0,SideL) pp
 172                                  , "="
 173                                  , unWriter body RuleMode_Ref (infixN0,SideR) pp
 174                                  ]