Language/Symantic/Repr/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.Repr.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 'Repr_Text'
  18
  19 -- | Interpreter's data.
  20 newtype Repr_Text h
  21  =      Repr_Text
  22  {    unRepr_Text
  23         -- Inherited attributes:
  24         :: Precedence
  25         -> Repr_Text_Lambda_Depth
  26         -- Synthetised attributes:
  27         -> Text
  28  }
  29 type Repr_Text_Lambda_Depth = Int
  30 instance Show (Repr_Text h) where
  31         show = Text.unpack . text_from_expr
  32
  33 -- | Interpreter.
  34 text_from_expr :: Repr_Text h -> Text
  35 text_from_expr r = unRepr_Text r precedence_Toplevel 0
  36
  37 -- * Helpers
  38
  39 -- ** Helpers for lambda applications
  40 repr_text_app1
  41  :: Text
  42  -> Repr_Text a1
  43  -> Repr_Text h
  44 repr_text_app1 name (Repr_Text a1) =
  45         Repr_Text $ \p v ->
  46                 let p' = precedence_App in
  47                 paren p p' $ name
  48                  <> " " <> a1 p' v
  49 repr_text_app2
  50  :: Text
  51  -> Repr_Text a1
  52  -> Repr_Text a2
  53  -> Repr_Text h
  54 repr_text_app2 name (Repr_Text a1) (Repr_Text a2) =
  55         Repr_Text $ \p v ->
  56                 let p' = precedence_App in
  57                 paren p p' $ name
  58                  <> " " <> a1 p' v
  59                  <> " " <> a2 p' v
  60 repr_text_app3
  61  :: Text
  62  -> Repr_Text a1
  63  -> Repr_Text a2
  64  -> Repr_Text a3
  65  -> Repr_Text h
  66 repr_text_app3 name (Repr_Text a1) (Repr_Text a2) (Repr_Text a3) =
  67         Repr_Text $ \p v ->
  68                 let p' = precedence_App in
  69                 paren p p' $ name
  70                  <> " " <> a1 p' v
  71                  <> " " <> a2 p' v
  72                  <> " " <> a3 p' v
  73 repr_text_infix
  74  :: Text
  75  -> Precedence
  76  -> Repr_Text a1
  77  -> Repr_Text a2
  78  -> Repr_Text h
  79 repr_text_infix name p' (Repr_Text a1) (Repr_Text a2) =
  80         Repr_Text $ \p v ->
  81                 paren p p' $ a1 p' v <> " " <> name <> " " <> a2 p' v
  82
  83 -- ** Type 'Precedence'
  84
  85 newtype Precedence = Precedence Int
  86  deriving (Eq, Ord, Show)
  87 precedence_pred :: Precedence -> Precedence
  88 precedence_pred (Precedence p) = Precedence (pred p)
  89 precedence_succ :: Precedence -> Precedence
  90 precedence_succ (Precedence p) = Precedence (succ p)
  91 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
  92 paren prec prec' x =
  93         if prec >= prec'
  94          then fromString "(" <> x <> fromString ")"
  95          else x
  96
  97 precedence_Toplevel  :: Precedence
  98 precedence_Toplevel   = Precedence 0
  99 precedence_App       :: Precedence
 100 precedence_App        = Precedence 10
 101 precedence_Atomic    :: Precedence
 102 precedence_Atomic     = Precedence maxBound