Language/LOL/Symantic/Repr/Text.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 -- | Interpreter to serialize an expression into a 'Text'.
   7 module Language.LOL.Symantic.Repr.Text where
   8
   9 import Data.Monoid ((<>))
  10 import Data.String (IsString(..))
  11 import Data.Text (Text)
  12 import qualified Data.Text as Text
  13
  14 import Language.LOL.Symantic.Expr
  15
  16 -- * Type 'Repr_Text'
  17
  18 -- | Interpreter's data.
  19 newtype Repr_Text (lam:: * -> *) h
  20  =      Repr_Text
  21  {    unRepr_Text
  22         -- Inherited attributes:
  23         :: Precedence
  24         -> Repr_Text_Lambda_Depth
  25         -- Synthetised attributes:
  26         -> Text
  27  }
  28 type Repr_Text_Lambda_Depth = Int
  29
  30 -- | Interpreter.
  31 text_from_expr :: Repr_Text lam h -> Text
  32 text_from_expr r = unRepr_Text r precedence_Toplevel 0
  33
  34 {-
  35 instance Show (Repr_Text lam a) where
  36         show = text_from_expr
  37 -}
  38 instance Sym_Lambda lam (Repr_Text lam) where
  39         type Lambda_from_Repr (Repr_Text lam) = lam
  40         app (Repr_Text f) (Repr_Text x) = Repr_Text $ \p v ->
  41                 let p' = precedence_App in
  42                 paren p p' $
  43                 f p' v <> " " <> x p' v
  44         inline     = repr_text_fun "!"
  45         val        = repr_text_fun ""
  46         lazy       = repr_text_fun "~"
  47
  48         let_inline = repr_text_let "!"
  49         let_val    = repr_text_let ""
  50         let_lazy   = repr_text_let "~"
  51
  52 -- ** Helpers for 'Sym_Lambda' instances
  53 repr_text_fun :: Text -> (Repr_Text lam a2 -> Repr_Text lam a1) -> Repr_Text lam a
  54 repr_text_fun mode e =
  55         Repr_Text $ \p v ->
  56                 let p' = precedence_Lambda in
  57                 let x = "x" <> Text.pack (show v) in
  58                 paren p p' $
  59                 "\\" <> mode <> x <> " -> " <>
  60                 unRepr_Text (e (Repr_Text $ \_p _v -> x)) p' (succ v)
  61 repr_text_let
  62  :: Text
  63  -> Repr_Text lam a1
  64  -> (Repr_Text lam a3 -> Repr_Text lam a2)
  65  -> Repr_Text lam a
  66 repr_text_let mode e in_ =
  67         Repr_Text $ \p v ->
  68                 let p' = precedence_Let in
  69                 let x = "x" <> Text.pack (show v) in
  70                 paren p p' $
  71                 "let" <> mode <> " " <> x <> " = " <> unRepr_Text e p (succ v) <> " in " <>
  72                 unRepr_Text (in_ (Repr_Text $ \_p _v -> x)) p (succ v)
  73
  74 instance Sym_Bool (Repr_Text lam) where
  75         bool a = Repr_Text $ \_p _v ->
  76                 Text.pack (show a)
  77         not (Repr_Text x) =
  78                 Repr_Text $ \p v ->
  79                         let p' = precedence_Not in
  80                         paren p p' $ "!" <> x p' v
  81         and (Repr_Text x) (Repr_Text y) =
  82                 Repr_Text $ \p v ->
  83                         let p' = precedence_And in
  84                         paren p p' $ x p' v <> " & " <> y p' v
  85         or (Repr_Text x) (Repr_Text y) =
  86                 Repr_Text $ \p v ->
  87                         let p' = precedence_Or in
  88                         paren p p'  $ x p' v <> " | " <> y p' v
  89         {-xor (Repr_Text x) (Repr_Text y) =
  90                 Repr_Text $ \p v ->
  91                         let p' = precedence_Xor in
  92                         paren p p'  $ x p' v <> " * " <> y p' v
  93         -}
  94 instance Sym_Int (Repr_Text lam) where
  95         int a = Repr_Text $ \_p _v ->
  96                 Text.pack (show a)
  97         neg (Repr_Text x) =
  98                 Repr_Text $ \p v ->
  99                         let p' = precedence_Neg in
 100                         paren p p' $ "-" <> x p' v
 101         add (Repr_Text x) (Repr_Text y) =
 102                 Repr_Text $ \p v ->
 103                         let p' = precedence_Add in
 104                         paren p p' $ x p' v <> " + " <> y p' v
 105 instance Sym_Maybe lam (Repr_Text lam) where
 106         maybe (Repr_Text n) (Repr_Text j) (Repr_Text m) =
 107                 Repr_Text $ \p v ->
 108                         let p' = precedence_App in
 109                         paren p p' $ "maybe"
 110                                  <> " " <> n p' v
 111                                  <> " " <> j p' v
 112                                  <> " " <> m p' v
 113 instance Sym_Maybe_Cons (Repr_Text lam) where
 114         nothing =
 115                 Repr_Text $ \_p _v ->
 116                         "nothing"
 117         just (Repr_Text a) =
 118                 Repr_Text $ \p v ->
 119                         let p' = precedence_App in
 120                         paren p p' $ "just "
 121                                  <> a (p') v
 122 instance Sym_If (Repr_Text lam) where
 123         if_ (Repr_Text cond) (Repr_Text ok) (Repr_Text ko) =
 124                 Repr_Text $ \p v ->
 125                         let p' = precedence_If in
 126                         paren p p' $
 127                         "if " <> cond p' v <>
 128                         " then " <> ok p' v <>
 129                         " else " <> ko p' v
 130 instance Sym_When (Repr_Text lam) where
 131         when (Repr_Text cond) (Repr_Text ok) =
 132                 Repr_Text $ \p v ->
 133                         let p' = precedence_If in
 134                         paren p p' $
 135                         "when " <> cond p' v <>
 136                         " " <> ok p' v
 137 instance Sym_Eq (Repr_Text lam) where
 138         eq (Repr_Text x) (Repr_Text y) =
 139                 Repr_Text $ \p v ->
 140                         let p' = precedence_Eq in
 141                         paren p p' $
 142                         x p' v <> " == " <> y p' v
 143
 144 -- ** Type 'Precedence'
 145
 146 newtype Precedence = Precedence Int
 147  deriving (Eq, Ord, Show)
 148 precedence_pred :: Precedence -> Precedence
 149 precedence_pred (Precedence p) = Precedence (pred p)
 150 precedence_succ :: Precedence -> Precedence
 151 precedence_succ (Precedence p) = Precedence (succ p)
 152 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
 153 paren prec prec' x =
 154         if prec >= prec'
 155          then fromString "(" <> x <> fromString ")"
 156          else x
 157
 158 precedence_Toplevel :: Precedence
 159 precedence_Toplevel  = Precedence 0
 160 precedence_Lambda   :: Precedence
 161 precedence_Lambda    = Precedence 1
 162 precedence_If       :: Precedence
 163 precedence_If        = Precedence 2
 164 precedence_Let      :: Precedence
 165 precedence_Let       = Precedence 3
 166 precedence_Eq       :: Precedence
 167 precedence_Eq        = Precedence 4
 168 precedence_Or       :: Precedence
 169 precedence_Or        = Precedence 5
 170 precedence_Xor      :: Precedence
 171 precedence_Xor       = Precedence 6
 172 precedence_And      :: Precedence
 173 precedence_And       = Precedence 7
 174 precedence_Add      :: Precedence
 175 precedence_Add       = precedence_And
 176 precedence_App      :: Precedence
 177 precedence_App       = Precedence 8
 178 precedence_Not      :: Precedence
 179 precedence_Not       = Precedence 9
 180 precedence_Neg      :: Precedence
 181 precedence_Neg       = precedence_Not
 182 precedence_Atomic   :: Precedence
 183 precedence_Atomic    = Precedence maxBound