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