Language/Symantic/Interpreting/Text.hs

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