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