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