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