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 textI_app0 :: Text -> TextI h
  34 textI_app0 name = TextI $ \_p _v -> name
  35 textI_app1
  36  :: Text
  37  -> TextI a1
  38  -> TextI h
  39 textI_app1 name (TextI a1) =
  40         TextI $ \p v ->
  41                 let p' = precedence_App in
  42                 paren p p' $ name
  43                  <> " " <> a1 p' v
  44 textI_app2
  45  :: Text
  46  -> TextI a1
  47  -> TextI a2
  48  -> TextI h
  49 textI_app2 name (TextI a1) (TextI a2) =
  50         TextI $ \p v ->
  51                 let p' = precedence_App in
  52                 paren p p' $ name
  53                  <> " " <> a1 p' v
  54                  <> " " <> a2 p' v
  55 textI_app3
  56  :: Text
  57  -> TextI a1
  58  -> TextI a2
  59  -> TextI a3
  60  -> TextI h
  61 textI_app3 name (TextI a1) (TextI a2) (TextI a3) =
  62         TextI $ \p v ->
  63                 let p' = precedence_App in
  64                 paren p p' $ name
  65                  <> " " <> a1 p' v
  66                  <> " " <> a2 p' v
  67                  <> " " <> a3 p' v
  68 textI_infix
  69  :: Text
  70  -> Precedence
  71  -> TextI a1
  72  -> TextI a2
  73  -> TextI h
  74 textI_infix name p' (TextI a1) (TextI a2) =
  75         TextI $ \p v ->
  76                 paren p p' $ a1 p' v <> " " <> name <> " " <> a2 p' v
  77
  78 -- ** Type 'Precedence'
  79
  80 newtype Precedence = Precedence Int
  81  deriving (Eq, Ord, Show)
  82 precedence_pred :: Precedence -> Precedence
  83 precedence_pred (Precedence p) = Precedence (pred p)
  84 precedence_succ :: Precedence -> Precedence
  85 precedence_succ (Precedence p) = Precedence (succ p)
  86 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
  87 paren prec prec' x =
  88         if prec >= prec'
  89          then fromString "(" <> x <> fromString ")"
  90          else x
  91
  92 precedence_Toplevel :: Precedence
  93 precedence_Toplevel  = Precedence 0
  94 precedence_App      :: Precedence
  95 precedence_App       = Precedence 10
  96 precedence_Atomic   :: Precedence
  97 precedence_Atomic    = Precedence maxBound