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 instance (Sym_Monad_Lam lam (Repr_Text lam), Applicative lam) => Sym_Monad (Repr_Text lam) where
 221         return (Repr_Text a) =
 222                 Repr_Text $ \p v ->
 223                         let p' = precedence_App in
 224                         paren p p' $ "return " <> a p' v
 225 instance Monad lam => Sym_Monad_Lam lam (Repr_Text lam) where
 226         (>>=) (Repr_Text g) (Repr_Text ma) =
 227                 Repr_Text $ \p v ->
 228                         let p' = precedence_Bind in
 229                         paren p p' $ g p' v <> " >>= " <> ma p' v
 230 instance Sym_Either (Repr_Text lam) where
 231         right (Repr_Text r) =
 232                 Repr_Text $ \p v ->
 233                         let p' = precedence_Toplevel in
 234                         paren p p' $ "right " <> r p' v
 235         left (Repr_Text l) =
 236                 Repr_Text $ \p v ->
 237                         let p' = precedence_Toplevel in
 238                         paren p p' $ "left " <> l p' v
 239
 240 -- ** Type 'Precedence'
 241
 242 newtype Precedence = Precedence Int
 243  deriving (Eq, Ord, Show)
 244 precedence_pred :: Precedence -> Precedence
 245 precedence_pred (Precedence p) = Precedence (pred p)
 246 precedence_succ :: Precedence -> Precedence
 247 precedence_succ (Precedence p) = Precedence (succ p)
 248 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
 249 paren prec prec' x =
 250         if prec >= prec'
 251          then fromString "(" <> x <> fromString ")"
 252          else x
 253
 254 precedence_Toplevel  :: Precedence
 255 precedence_Toplevel   = Precedence 0
 256 precedence_Lambda    :: Precedence
 257 precedence_Lambda     = Precedence 1
 258 precedence_Bind      :: Precedence
 259 precedence_Bind       = precedence_Lambda
 260 precedence_If        :: Precedence
 261 precedence_If         = Precedence 2
 262 precedence_Let       :: Precedence
 263 precedence_Let        = Precedence 3
 264 precedence_Eq        :: Precedence
 265 precedence_Eq         = Precedence 4
 266 precedence_LtStarGt  :: Precedence
 267 precedence_LtStarGt   = precedence_Eq
 268 precedence_Or        :: Precedence
 269 precedence_Or         = Precedence 5
 270 precedence_Xor       :: Precedence
 271 precedence_Xor        = precedence_Or
 272 precedence_And       :: Precedence
 273 precedence_And        = Precedence 6
 274 precedence_Add       :: Precedence
 275 precedence_Add        = precedence_And
 276 precedence_Sub       :: Precedence
 277 precedence_Sub        = precedence_Add
 278 precedence_Mul       :: Precedence
 279 precedence_Mul        = Precedence 7
 280 precedence_Mod       :: Precedence
 281 precedence_Mod        = precedence_Mul
 282 precedence_App       :: Precedence
 283 precedence_App        = Precedence 8
 284 precedence_Not       :: Precedence
 285 precedence_Not        = Precedence 9
 286 precedence_Neg       :: Precedence
 287 precedence_Neg        = precedence_Not
 288 precedence_Atomic    :: Precedence
 289 precedence_Atomic     = Precedence maxBound