Language/Symantic/Interpreting/Text.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 -- | Interpreter to serialize an expression into a 'Text'.
   3 module Language.Symantic.Interpreting.Text where
   4
   5 import Data.Monoid ((<>))
   6 import Data.String (IsString(..))
   7 import Data.Text (Text)
   8 import qualified Data.Text as Text
   9 import Prelude hiding (Integral(..))
  10
  11 -- * Type 'TextI'
  12
  13 -- | Interpreter's data.
  14 newtype TextI h
  15  =      TextI
  16  {    unTextI -- Inherited attributes:
  17               :: Precedence
  18               -> TextI_Lambda_Depth
  19               -- Synthetised attributes:
  20               -> Text
  21  }
  22 type TextI_Lambda_Depth = Int
  23 instance Show (TextI h) where
  24         show = Text.unpack . text_from_term
  25
  26 -- | Interpreter.
  27 text_from_term :: TextI h -> Text
  28 text_from_term r = unTextI r precedence_Toplevel 0
  29
  30 -- * Helpers
  31
  32 -- ** Helpers for lambda applications
  33 textI0 :: Text -> TextI h
  34 textI0 name = TextI $ \_p _v -> name
  35 textI1 :: Text -> TextI a1 -> TextI h
  36 textI1 name (TextI a1) =
  37         TextI $ \p v ->
  38                 let p' = precedence_App in
  39                 paren p p' $ name
  40                  <> " " <> a1 p' v
  41 textI2 :: Text -> TextI a1 -> TextI a2 -> TextI h
  42 textI2 name (TextI a1) (TextI a2) =
  43         TextI $ \p v ->
  44                 let p' = precedence_App in
  45                 paren p p' $ name
  46                  <> " " <> a1 p' v
  47                  <> " " <> a2 p' v
  48 textI3 :: Text -> TextI a1 -> TextI a2 -> TextI a3 -> TextI h
  49 textI3 name (TextI a1) (TextI a2) (TextI a3) =
  50         TextI $ \p v ->
  51                 let p' = precedence_App in
  52                 paren p p' $ name
  53                  <> " " <> a1 p' v
  54                  <> " " <> a2 p' v
  55                  <> " " <> a3 p' v
  56 textI_infix :: Text -> Precedence -> TextI a1 -> TextI a2 -> TextI h
  57 textI_infix name p' (TextI a1) (TextI a2) =
  58         TextI $ \p v ->
  59                 paren p p' $ a1 p' v <> " " <> name <> " " <> a2 p' v
  60
  61 -- ** Type 'Precedence'
  62
  63 newtype Precedence = Precedence Int
  64  deriving (Eq, Ord, Show)
  65 precedence_pred :: Precedence -> Precedence
  66 precedence_pred (Precedence p) = Precedence (pred p)
  67 precedence_succ :: Precedence -> Precedence
  68 precedence_succ (Precedence p) = Precedence (succ p)
  69 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
  70 paren prec prec' x =
  71         if prec >= prec'
  72          then fromString "(" <> x <> fromString ")"
  73          else x
  74
  75 precedence_Toplevel :: Precedence
  76 precedence_Toplevel  = Precedence 0
  77 precedence_App      :: Precedence
  78 precedence_App       = Precedence 10
  79 precedence_Atomic   :: Precedence
  80 precedence_Atomic    = Precedence maxBound