Language/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.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.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         (&&) (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         (||) (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'  $ "xor " <> x p' v <> " " <> y p' v
  93 instance Sym_Int (Repr_Text lam) where
  94         int a = Repr_Text $ \_p _v ->
  95                 Text.pack (show a)
  96         abs (Repr_Text x) =
  97                 Repr_Text $ \p v ->
  98                         let p' = precedence_App in
  99                         paren p p' $ "abs " <> x p' v
 100         negate (Repr_Text x) =
 101                 Repr_Text $ \p v ->
 102                         let p' = precedence_Neg in
 103                         paren p p' $ "-" <> x p' v
 104         (+) (Repr_Text x) (Repr_Text y) =
 105                 Repr_Text $ \p v ->
 106                         let p' = precedence_Add in
 107                         paren p p' $ x p' v <> " + " <> y p' v
 108         (-) (Repr_Text x) (Repr_Text y) =
 109                 Repr_Text $ \p v ->
 110                         let p' = precedence_Sub in
 111                         paren p p' $ x p' v <> " - " <> y p' v
 112         (*) (Repr_Text x) (Repr_Text y) =
 113                 Repr_Text $ \p v ->
 114                         let p' = precedence_Mul in
 115                         paren p p' $ x p' v <> " * " <> y p' v
 116         mod (Repr_Text x) (Repr_Text y) =
 117                 Repr_Text $ \p v ->
 118                         let p' = precedence_Mod in
 119                         paren p p' $ x p' v <> " % " <> y p' v
 120 instance Sym_Maybe (Repr_Text lam) where
 121         nothing =
 122                 Repr_Text $ \_p _v ->
 123                         "nothing"
 124         just (Repr_Text a) =
 125                 Repr_Text $ \p v ->
 126                         let p' = precedence_App in
 127                         paren p p' $ "just "
 128                                  <> a (p') v
 129 instance Sym_Maybe_Lam lam (Repr_Text lam) where
 130         maybe (Repr_Text n) (Repr_Text j) (Repr_Text m) =
 131                 Repr_Text $ \p v ->
 132                         let p' = precedence_App in
 133                         paren p p' $ "maybe"
 134                                  <> " " <> n p' v
 135                                  <> " " <> j p' v
 136                                  <> " " <> m p' v
 137 instance Sym_If (Repr_Text lam) where
 138         if_ (Repr_Text cond) (Repr_Text ok) (Repr_Text ko) =
 139                 Repr_Text $ \p v ->
 140                         let p' = precedence_If in
 141                         paren p p' $
 142                         "if " <> cond p' v <>
 143                         " then " <> ok p' v <>
 144                         " else " <> ko p' v
 145 instance Sym_When (Repr_Text lam) where
 146         when (Repr_Text cond) (Repr_Text ok) =
 147                 Repr_Text $ \p v ->
 148                         let p' = precedence_If in
 149                         paren p p' $
 150                         "when " <> cond p' v <>
 151                         " " <> ok p' v
 152 instance Sym_Eq (Repr_Text lam) where
 153         (==) (Repr_Text x) (Repr_Text y) =
 154                 Repr_Text $ \p v ->
 155                         let p' = precedence_Eq in
 156                         paren p p' $
 157                         x p' v <> " == " <> y p' v
 158 instance Sym_Ord (Repr_Text lam) where
 159         compare (Repr_Text x) (Repr_Text y) =
 160                 Repr_Text $ \p v ->
 161                         let p' = precedence_Eq in
 162                         paren p p' $
 163                         "compare " <> x p' v <> " " <> y p' v
 164 instance Sym_List (Repr_Text lam) where
 165         list_empty = Repr_Text $ \_p _v ->
 166                 "[]"
 167         list_cons (Repr_Text x) (Repr_Text xs) =
 168                 Repr_Text $ \p v ->
 169                         let p' = precedence_App in
 170                         paren p p' $
 171                         x p' v <> ":" <> xs p' v
 172         list l = Repr_Text $ \_p v ->
 173                 let p' = precedence_Toplevel in
 174                 "[" <> Text.intercalate ", " ((\(Repr_Text a) -> a p' v) <$> l) <> "]"
 175 instance Sym_List_Lam lam (Repr_Text lam) where
 176         list_filter (Repr_Text f) (Repr_Text l) =
 177                 Repr_Text $ \p v ->
 178                         let p' = precedence_App in
 179                         paren p p' $
 180                         "list_filter " <> f p' v <> ":" <> l p' v
 181 instance Sym_Tuple2 (Repr_Text lam) where
 182         tuple2 (Repr_Text a) (Repr_Text b) =
 183                 Repr_Text $ \_p v ->
 184                         let p' = precedence_Toplevel in
 185                         "(" <> a p' v <> ", " <> b p' v <> ")"
 186 instance Monad lam => Sym_Map (Repr_Text lam) where
 187         map_from_list (Repr_Text l) =
 188                 Repr_Text $ \_p v ->
 189                         let p' = precedence_App in
 190                         "map_from_list " <> l p' v
 191 instance Monad lam => Sym_Map_Lam lam (Repr_Text lam) where
 192         map_map (Repr_Text f) (Repr_Text m) =
 193                 Repr_Text $ \_p v ->
 194                         let p' = precedence_App in
 195                         "map_map " <> f p' v <> " " <> m p' v
 196 instance Monad lam => Sym_Functor lam (Repr_Text lam) where
 197         fmap (Repr_Text f) (Repr_Text m) =
 198                 Repr_Text $ \_p v ->
 199                         let p' = precedence_App in
 200                         "fmap " <> f p' v <> " " <> m p' v
 201
 202 -- ** Type 'Precedence'
 203
 204 newtype Precedence = Precedence Int
 205  deriving (Eq, Ord, Show)
 206 precedence_pred :: Precedence -> Precedence
 207 precedence_pred (Precedence p) = Precedence (pred p)
 208 precedence_succ :: Precedence -> Precedence
 209 precedence_succ (Precedence p) = Precedence (succ p)
 210 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
 211 paren prec prec' x =
 212         if prec >= prec'
 213          then fromString "(" <> x <> fromString ")"
 214          else x
 215
 216 precedence_Toplevel  :: Precedence
 217 precedence_Toplevel   = Precedence 0
 218 precedence_Lambda    :: Precedence
 219 precedence_Lambda     = Precedence 1
 220 precedence_If        :: Precedence
 221 precedence_If         = Precedence 2
 222 precedence_Let       :: Precedence
 223 precedence_Let        = Precedence 3
 224 precedence_Eq        :: Precedence
 225 precedence_Eq         = Precedence 4
 226 precedence_Or        :: Precedence
 227 precedence_Or         = Precedence 5
 228 precedence_Xor       :: Precedence
 229 precedence_Xor        = precedence_Or
 230 precedence_And       :: Precedence
 231 precedence_And        = Precedence 6
 232 precedence_Add       :: Precedence
 233 precedence_Add        = precedence_And
 234 precedence_Sub       :: Precedence
 235 precedence_Sub        = precedence_Add
 236 precedence_Mul       :: Precedence
 237 precedence_Mul        = Precedence 7
 238 precedence_Mod       :: Precedence
 239 precedence_Mod        = precedence_Mul
 240 precedence_App       :: Precedence
 241 precedence_App        = Precedence 8
 242 precedence_Not       :: Precedence
 243 precedence_Not        = Precedence 9
 244 precedence_Neg       :: Precedence
 245 precedence_Neg        = precedence_Not
 246 precedence_Atomic    :: Precedence
 247 precedence_Atomic     = Precedence maxBound