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 type instance Lambda_from_Repr (Repr_Text lam) = lam
  39 instance Sym_Lambda_App lam (Repr_Text lam) where
  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 instance Sym_Lambda_Inline lam (Repr_Text lam) where
  45         inline     = repr_text_fun "!"
  46         let_inline = repr_text_let "!"
  47 instance Sym_Lambda_Val lam (Repr_Text lam) where
  48         val        = repr_text_fun ""
  49         let_val    = repr_text_let ""
  50 instance Sym_Lambda_Lazy lam (Repr_Text lam) where
  51         lazy       = repr_text_fun "~"
  52         let_lazy   = repr_text_let "~"
  53
  54 -- ** Helpers for 'Sym_Lambda' instances
  55 repr_text_fun :: Text -> (Repr_Text lam a2 -> Repr_Text lam a1) -> Repr_Text lam a
  56 repr_text_fun mode e =
  57         Repr_Text $ \p v ->
  58                 let p' = precedence_Lambda in
  59                 let x = "x" <> Text.pack (show v) in
  60                 paren p p' $
  61                 "\\" <> mode <> x <> " -> " <>
  62                 unRepr_Text (e (Repr_Text $ \_p _v -> x)) p' (succ v)
  63 repr_text_let
  64  :: Text
  65  -> Repr_Text lam a1
  66  -> (Repr_Text lam a3 -> Repr_Text lam a2)
  67  -> Repr_Text lam a
  68 repr_text_let mode e in_ =
  69         Repr_Text $ \p v ->
  70                 let p' = precedence_Let in
  71                 let x = "x" <> Text.pack (show v) in
  72                 paren p p' $
  73                 "let" <> mode <> " " <> x <> " = " <> unRepr_Text e p (succ v) <> " in " <>
  74                 unRepr_Text (in_ (Repr_Text $ \_p _v -> x)) p (succ v)
  75
  76 instance Sym_Bool (Repr_Text lam) where
  77         bool a = Repr_Text $ \_p _v ->
  78                 Text.pack (show a)
  79         not (Repr_Text x) =
  80                 Repr_Text $ \p v ->
  81                         let p' = precedence_Not in
  82                         paren p p' $ "!" <> x p' v
  83         (&&) (Repr_Text x) (Repr_Text y) =
  84                 Repr_Text $ \p v ->
  85                         let p' = precedence_And in
  86                         paren p p' $ x p' v <> " && " <> y p' v
  87         (||) (Repr_Text x) (Repr_Text y) =
  88                 Repr_Text $ \p v ->
  89                         let p' = precedence_Or in
  90                         paren p p'  $ x p' v <> " || " <> y p' v
  91         xor (Repr_Text x) (Repr_Text y) =
  92                 Repr_Text $ \p v ->
  93                         let p' = precedence_Xor in
  94                         paren p p'  $ "xor " <> x p' v <> " " <> y p' v
  95 instance Sym_Int (Repr_Text lam) where
  96         int a = Repr_Text $ \_p _v ->
  97                 Text.pack (show a)
  98         abs (Repr_Text x) =
  99                 Repr_Text $ \p v ->
 100                         let p' = precedence_App in
 101                         paren p p' $ "abs " <> x p' v
 102         negate (Repr_Text x) =
 103                 Repr_Text $ \p v ->
 104                         let p' = precedence_Neg in
 105                         paren p p' $ "-" <> x p' v
 106         (+) (Repr_Text x) (Repr_Text y) =
 107                 Repr_Text $ \p v ->
 108                         let p' = precedence_Add in
 109                         paren p p' $ x p' v <> " + " <> y p' v
 110         (-) (Repr_Text x) (Repr_Text y) =
 111                 Repr_Text $ \p v ->
 112                         let p' = precedence_Sub in
 113                         paren p p' $ x p' v <> " - " <> y p' v
 114         (*) (Repr_Text x) (Repr_Text y) =
 115                 Repr_Text $ \p v ->
 116                         let p' = precedence_Mul in
 117                         paren p p' $ x p' v <> " * " <> y p' v
 118         mod (Repr_Text x) (Repr_Text y) =
 119                 Repr_Text $ \p v ->
 120                         let p' = precedence_Mod in
 121                         paren p p' $ x p' v <> " % " <> y p' v
 122 instance Sym_Maybe (Repr_Text lam) where
 123         nothing =
 124                 Repr_Text $ \_p _v ->
 125                         "nothing"
 126         just (Repr_Text a) =
 127                 Repr_Text $ \p v ->
 128                         let p' = precedence_App in
 129                         paren p p' $ "just "
 130                                  <> a (p') v
 131 instance Sym_Maybe_Lam lam (Repr_Text lam) where
 132         maybe (Repr_Text n) (Repr_Text j) (Repr_Text m) =
 133                 Repr_Text $ \p v ->
 134                         let p' = precedence_App in
 135                         paren p p' $ "maybe"
 136                                  <> " " <> n p' v
 137                                  <> " " <> j p' v
 138                                  <> " " <> m p' v
 139 instance Sym_If (Repr_Text lam) where
 140         if_ (Repr_Text cond) (Repr_Text ok) (Repr_Text ko) =
 141                 Repr_Text $ \p v ->
 142                         let p' = precedence_If in
 143                         paren p p' $
 144                         "if " <> cond p' v <>
 145                         " then " <> ok p' v <>
 146                         " else " <> ko p' v
 147 instance Sym_When (Repr_Text lam) where
 148         when (Repr_Text cond) (Repr_Text ok) =
 149                 Repr_Text $ \p v ->
 150                         let p' = precedence_If in
 151                         paren p p' $
 152                         "when " <> cond p' v <>
 153                         " " <> ok p' v
 154 instance Sym_Eq (Repr_Text lam) where
 155         (==) (Repr_Text x) (Repr_Text y) =
 156                 Repr_Text $ \p v ->
 157                         let p' = precedence_Eq in
 158                         paren p p' $
 159                         x p' v <> " == " <> y p' v
 160 instance Sym_Ord (Repr_Text lam) where
 161         compare (Repr_Text x) (Repr_Text y) =
 162                 Repr_Text $ \p v ->
 163                         let p' = precedence_Eq in
 164                         paren p p' $
 165                         "compare " <> x p' v <> " " <> y p' v
 166 instance Sym_List (Repr_Text lam) where
 167         list_empty = Repr_Text $ \_p _v ->
 168                 "[]"
 169         list_cons (Repr_Text x) (Repr_Text xs) =
 170                 Repr_Text $ \p v ->
 171                         let p' = precedence_App in
 172                         paren p p' $
 173                         x p' v <> ":" <> xs p' v
 174         list l = Repr_Text $ \_p v ->
 175                 let p' = precedence_Toplevel in
 176                 "[" <> Text.intercalate ", " ((\(Repr_Text a) -> a p' v) Prelude.<$> l) <> "]"
 177 instance Sym_List_Lam lam (Repr_Text lam) where
 178         list_filter (Repr_Text f) (Repr_Text l) =
 179                 Repr_Text $ \p v ->
 180                         let p' = precedence_App in
 181                         paren p p' $
 182                         "list_filter " <> f p' v <> ":" <> l p' v
 183 instance Sym_Tuple2 (Repr_Text lam) where
 184         tuple2 (Repr_Text a) (Repr_Text b) =
 185                 Repr_Text $ \_p v ->
 186                         let p' = precedence_Toplevel in
 187                         "(" <> a p' v <> ", " <> b p' v <> ")"
 188 instance Monad lam => Sym_Map (Repr_Text lam) where
 189         map_from_list (Repr_Text l) =
 190                 Repr_Text $ \_p v ->
 191                         let p' = precedence_App in
 192                         "map_from_list " <> l p' v
 193 instance Monad lam => Sym_Map_Lam lam (Repr_Text lam) where
 194         map_map (Repr_Text f) (Repr_Text m) =
 195                 Repr_Text $ \_p v ->
 196                         let p' = precedence_App in
 197                         "map_map " <> f p' v <> " " <> m p' v
 198 instance Monad lam => Sym_Functor lam (Repr_Text lam) where
 199         fmap (Repr_Text f) (Repr_Text m) =
 200                 Repr_Text $ \_p v ->
 201                         let p' = precedence_App in
 202                         "fmap " <> f p' v <> " " <> m p' v
 203 instance Monad lam => Sym_Applicative (Repr_Text lam) where
 204         pure (Repr_Text a) =
 205                 Repr_Text $ \_p v ->
 206                         let p' = precedence_App in
 207                         "pure " <> a p' v
 208 instance Monad lam => Sym_Applicative_Lam lam (Repr_Text lam) where
 209         (<*>) (Repr_Text fg) (Repr_Text fa) =
 210                 Repr_Text $ \p v ->
 211                         let p' = precedence_LtStarGt in
 212                         paren p p' $ fg p' v <> " <*> " <> fa p' v
 213
 214 -- ** Type 'Precedence'
 215
 216 newtype Precedence = Precedence Int
 217  deriving (Eq, Ord, Show)
 218 precedence_pred :: Precedence -> Precedence
 219 precedence_pred (Precedence p) = Precedence (pred p)
 220 precedence_succ :: Precedence -> Precedence
 221 precedence_succ (Precedence p) = Precedence (succ p)
 222 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
 223 paren prec prec' x =
 224         if prec >= prec'
 225          then fromString "(" <> x <> fromString ")"
 226          else x
 227
 228 precedence_Toplevel  :: Precedence
 229 precedence_Toplevel   = Precedence 0
 230 precedence_Lambda    :: Precedence
 231 precedence_Lambda     = Precedence 1
 232 precedence_If        :: Precedence
 233 precedence_If         = Precedence 2
 234 precedence_Let       :: Precedence
 235 precedence_Let        = Precedence 3
 236 precedence_Eq        :: Precedence
 237 precedence_Eq         = Precedence 4
 238 precedence_LtStarGt  :: Precedence
 239 precedence_LtStarGt   = precedence_Eq
 240 precedence_Or        :: Precedence
 241 precedence_Or         = Precedence 5
 242 precedence_Xor       :: Precedence
 243 precedence_Xor        = precedence_Or
 244 precedence_And       :: Precedence
 245 precedence_And        = Precedence 6
 246 precedence_Add       :: Precedence
 247 precedence_Add        = precedence_And
 248 precedence_Sub       :: Precedence
 249 precedence_Sub        = precedence_Add
 250 precedence_Mul       :: Precedence
 251 precedence_Mul        = Precedence 7
 252 precedence_Mod       :: Precedence
 253 precedence_Mod        = precedence_Mul
 254 precedence_App       :: Precedence
 255 precedence_App        = Precedence 8
 256 precedence_Not       :: Precedence
 257 precedence_Not        = Precedence 9
 258 precedence_Neg       :: Precedence
 259 precedence_Neg        = precedence_Not
 260 precedence_Atomic    :: Precedence
 261 precedence_Atomic     = Precedence maxBound