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
  74 -- ** Type 'Precedence'
  75
  76 newtype Precedence = Precedence Int
  77  deriving (Eq, Ord, Show)
  78 precedence_pred :: Precedence -> Precedence
  79 precedence_pred (Precedence p) = Precedence (pred p)
  80 precedence_succ :: Precedence -> Precedence
  81 precedence_succ (Precedence p) = Precedence (succ p)
  82 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
  83 paren prec prec' x =
  84         if prec >= prec'
  85          then fromString "(" <> x <> fromString ")"
  86          else x
  87
  88 precedence_Toplevel  :: Precedence
  89 precedence_Toplevel   = Precedence 0
  90 precedence_Lambda    :: Precedence
  91 precedence_Lambda     = Precedence 1
  92 precedence_Bind      :: Precedence
  93 precedence_Bind       = precedence_Lambda
  94 precedence_If        :: Precedence
  95 precedence_If         = Precedence 2
  96 precedence_Let       :: Precedence
  97 precedence_Let        = Precedence 3
  98 precedence_Eq        :: Precedence
  99 precedence_Eq         = Precedence 4
 100 precedence_LtStarGt  :: Precedence
 101 precedence_LtStarGt   = precedence_Eq
 102 precedence_Or        :: Precedence
 103 precedence_Or         = Precedence 5
 104 precedence_List_Cons :: Precedence
 105 precedence_List_Cons  = Precedence 5
 106 precedence_Xor       :: Precedence
 107 precedence_Xor        = precedence_Or
 108 precedence_And       :: Precedence
 109 precedence_And        = Precedence 6
 110 precedence_Add       :: Precedence
 111 precedence_Add        = precedence_And
 112 precedence_Sub       :: Precedence
 113 precedence_Sub        = precedence_Add
 114 precedence_Mul       :: Precedence
 115 precedence_Mul        = Precedence 7
 116 precedence_Integral  :: Precedence
 117 precedence_Integral   = precedence_Mul
 118 precedence_App       :: Precedence
 119 precedence_App        = Precedence 8
 120 precedence_Not       :: Precedence
 121 precedence_Not        = Precedence 9
 122 precedence_Neg       :: Precedence
 123 precedence_Neg        = precedence_Not
 124 precedence_Atomic    :: Precedence
 125 precedence_Atomic     = Precedence maxBound