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 hiding ((<>))
  17
  18 -- * Type 'Repr_Text'
  19
  20 -- | Interpreter's data.
  21 newtype Repr_Text 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 h -> Text
  34 text_from_expr r = unRepr_Text r precedence_Toplevel 0
  35
  36 {-
  37 instance Show (Repr_Text h) where
  38         show = text_from_expr
  39 -}
  40 instance Sym_Lambda Repr_Text where
  41         ($$) (Repr_Text a1) (Repr_Text a2) =
  42                 Repr_Text $ \p v ->
  43                         let p' = precedence_App in
  44                         paren p p' $ a1 p' v <> " " <> a2 p' v
  45         lam f =
  46                 Repr_Text $ \p v ->
  47                         let p' = precedence_Lambda in
  48                         let x = "x" <> Text.pack (show v) in
  49                         paren p p' $
  50                         "\\" <> x <> " -> " <>
  51                         unRepr_Text (f (Repr_Text $ \_p _v -> x)) p' (succ v)
  52         let_ e in_ =
  53                 Repr_Text $ \p v ->
  54                         let p' = precedence_Let in
  55                         let x = "x" <> Text.pack (show v) in
  56                         paren p p' $
  57                         "let" <> " " <> x <> " = " <> unRepr_Text e p (succ v) <> " in " <>
  58                         unRepr_Text (in_ (Repr_Text $ \_p _v -> x)) p (succ v)
  59 instance Sym_Bool Repr_Text where
  60         bool a = Repr_Text $ \_p _v ->
  61                 Text.pack (show a)
  62         not (Repr_Text x) =
  63                 Repr_Text $ \p v ->
  64                         let p' = precedence_Not in
  65                         paren p p' $ "!" <> x p' v
  66         (&&) (Repr_Text x) (Repr_Text y) =
  67                 Repr_Text $ \p v ->
  68                         let p' = precedence_And in
  69                         paren p p' $ x p' v <> " && " <> y p' v
  70         (||) (Repr_Text x) (Repr_Text y) =
  71                 Repr_Text $ \p v ->
  72                         let p' = precedence_Or in
  73                         paren p p'  $ x p' v <> " || " <> y p' v
  74         xor (Repr_Text x) (Repr_Text y) =
  75                 Repr_Text $ \p v ->
  76                         let p' = precedence_Xor in
  77                         paren p p'  $ "xor " <> x p' v <> " " <> y p' v
  78 instance Sym_Int Repr_Text where
  79         int a = Repr_Text $ \_p _v ->
  80                 Text.pack (show a)
  81         abs = repr_text_app1 "abs"
  82         negate (Repr_Text x) =
  83                 Repr_Text $ \p v ->
  84                         let p' = precedence_Neg in
  85                         paren p p' $ "-" <> x p' v
  86         (+) (Repr_Text x) (Repr_Text y) =
  87                 Repr_Text $ \p v ->
  88                         let p' = precedence_Add in
  89                         paren p p' $ x p' v <> " + " <> y p' v
  90         (-) (Repr_Text x) (Repr_Text y) =
  91                 Repr_Text $ \p v ->
  92                         let p' = precedence_Sub in
  93                         paren p p' $ x p' v <> " - " <> y p' v
  94         (*) (Repr_Text x) (Repr_Text y) =
  95                 Repr_Text $ \p v ->
  96                         let p' = precedence_Mul in
  97                         paren p p' $ x p' v <> " * " <> y p' v
  98         mod (Repr_Text x) (Repr_Text y) =
  99                 Repr_Text $ \p v ->
 100                         let p' = precedence_Mod in
 101                         paren p p' $ x p' v <> " % " <> y p' v
 102 instance Sym_Text Repr_Text where
 103         text a = Repr_Text $ \_p _v -> Text.pack (show a)
 104 instance Sym_Maybe Repr_Text where
 105         nothing =
 106                 Repr_Text $ \_p _v ->
 107                         "nothing"
 108         just  = repr_text_app1 "just"
 109         maybe = repr_text_app3 "maybe"
 110 instance Sym_If Repr_Text where
 111         if_ (Repr_Text cond) (Repr_Text ok) (Repr_Text ko) =
 112                 Repr_Text $ \p v ->
 113                         let p' = precedence_If in
 114                         paren p p' $
 115                         "if " <> cond p' v <>
 116                         " then " <> ok p' v <>
 117                         " else " <> ko p' v
 118 instance Sym_When Repr_Text where
 119         when (Repr_Text cond) (Repr_Text ok) =
 120                 Repr_Text $ \p v ->
 121                         let p' = precedence_If in
 122                         paren p p' $
 123                         "when " <> cond p' v <>
 124                         " " <> ok p' v
 125 instance Sym_Eq Repr_Text where
 126         (==) (Repr_Text x) (Repr_Text y) =
 127                 Repr_Text $ \p v ->
 128                         let p' = precedence_Eq in
 129                         paren p p' $
 130                         x p' v <> " == " <> y p' v
 131 instance Sym_Ord Repr_Text where
 132         compare (Repr_Text x) (Repr_Text y) =
 133                 Repr_Text $ \p v ->
 134                         let p' = precedence_Eq in
 135                         paren p p' $
 136                         "compare " <> x p' v <> " " <> y p' v
 137 instance Sym_List Repr_Text where
 138         list_empty = Repr_Text $ \_p _v ->
 139                 "[]"
 140         list_cons (Repr_Text x) (Repr_Text xs) =
 141                 Repr_Text $ \p v ->
 142                         let p' = precedence_List_Cons in
 143                         paren p p' $ x p' v <> ":" <> xs p' v
 144         list l = Repr_Text $ \_p v ->
 145                 let p' = precedence_Toplevel in
 146                 "[" <> Text.intercalate ", " ((\(Repr_Text a) -> a p' v) Prelude.<$> l) <> "]"
 147         list_filter  = repr_text_app2 "list_filter"
 148         list_zipWith = repr_text_app3 "list_zipWith"
 149         list_reverse = repr_text_app1 "list_reverse"
 150 instance Sym_Tuple2 Repr_Text where
 151         tuple2 (Repr_Text a) (Repr_Text b) =
 152                 Repr_Text $ \_p v ->
 153                         let p' = precedence_Toplevel in
 154                         "(" <> a p' v <> ", " <> b p' v <> ")"
 155         fst = repr_text_app1 "fst"
 156         snd = repr_text_app1 "snd"
 157 instance Sym_Map Repr_Text where
 158         map_from_list    = repr_text_app1 "map_from_list"
 159         mapWithKey       = repr_text_app2 "mapWithKey"
 160         map_lookup       = repr_text_app2 "map_lookup"
 161         map_keys         = repr_text_app1 "map_keys"
 162         map_member       = repr_text_app2 "map_member"
 163         map_insert       = repr_text_app3 "map_insert"
 164         map_delete       = repr_text_app2 "map_delete"
 165         map_difference   = repr_text_app2 "map_difference"
 166         map_foldrWithKey = repr_text_app3 "map_foldrWithKey"
 167 instance Sym_Functor Repr_Text where
 168         fmap = repr_text_app2 "fmap"
 169 instance Sym_Applicative Repr_Text where
 170         pure = repr_text_app1 "pure"
 171         (<*>) (Repr_Text fg) (Repr_Text fa) =
 172                 Repr_Text $ \p v ->
 173                         let p' = precedence_LtStarGt in
 174                         paren p p' $ fg p' v <> " <*> " <> fa p' v
 175 instance Sym_Traversable Repr_Text where
 176         traverse = repr_text_app2 "traverse"
 177 instance Sym_Monad Repr_Text where
 178         return = repr_text_app1 "return"
 179         (>>=) (Repr_Text g) (Repr_Text ma) =
 180                 Repr_Text $ \p v ->
 181                         let p' = precedence_Bind in
 182                         paren p p' $ g p' v <> " >>= " <> ma p' v
 183 instance Sym_Either Repr_Text where
 184         right = repr_text_app1 "right"
 185         left  = repr_text_app1 "left"
 186 instance Sym_IO Repr_Text where
 187         io_hClose   = repr_text_app1 "io_hClose"
 188         io_openFile = repr_text_app2 "io_openFile"
 189 instance Sym_Foldable Repr_Text where
 190         foldMap = repr_text_app2 "foldMap"
 191         null    = repr_text_app1 "null"
 192         length  = repr_text_app1 "length"
 193         minimum = repr_text_app1 "minimum"
 194         maximum = repr_text_app1 "maximum"
 195         elem    = repr_text_app2 "elem"
 196 instance Sym_Monoid Repr_Text where
 197         mempty = Repr_Text $ \_p _v -> "mempty"
 198         mappend = repr_text_app2 "mappend"
 199
 200 -- * Helpers
 201
 202 -- ** Helpers for lambda applications
 203 repr_text_app1
 204  :: Text
 205  -> Repr_Text a1
 206  -> Repr_Text h
 207 repr_text_app1 name (Repr_Text a1) =
 208         Repr_Text $ \p v ->
 209                 let p' = precedence_App in
 210                 paren p p' $ name
 211                  <> " " <> a1 p' v
 212 repr_text_app2
 213  :: Text
 214  -> Repr_Text a1
 215  -> Repr_Text a2
 216  -> Repr_Text h
 217 repr_text_app2 name (Repr_Text a1) (Repr_Text a2) =
 218         Repr_Text $ \p v ->
 219                 let p' = precedence_App in
 220                 paren p p' $ name
 221                  <> " " <> a1 p' v
 222                  <> " " <> a2 p' v
 223 repr_text_app3
 224  :: Text
 225  -> Repr_Text a1
 226  -> Repr_Text a2
 227  -> Repr_Text a3
 228  -> Repr_Text h
 229 repr_text_app3 name (Repr_Text a1) (Repr_Text a2) (Repr_Text a3) =
 230         Repr_Text $ \p v ->
 231                 let p' = precedence_App in
 232                 paren p p' $ name
 233                  <> " " <> a1 p' v
 234                  <> " " <> a2 p' v
 235                  <> " " <> a3 p' v
 236
 237 -- ** Type 'Precedence'
 238
 239 newtype Precedence = Precedence Int
 240  deriving (Eq, Ord, Show)
 241 precedence_pred :: Precedence -> Precedence
 242 precedence_pred (Precedence p) = Precedence (pred p)
 243 precedence_succ :: Precedence -> Precedence
 244 precedence_succ (Precedence p) = Precedence (succ p)
 245 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
 246 paren prec prec' x =
 247         if prec >= prec'
 248          then fromString "(" <> x <> fromString ")"
 249          else x
 250
 251 precedence_Toplevel  :: Precedence
 252 precedence_Toplevel   = Precedence 0
 253 precedence_Lambda    :: Precedence
 254 precedence_Lambda     = Precedence 1
 255 precedence_Bind      :: Precedence
 256 precedence_Bind       = precedence_Lambda
 257 precedence_If        :: Precedence
 258 precedence_If         = Precedence 2
 259 precedence_Let       :: Precedence
 260 precedence_Let        = Precedence 3
 261 precedence_Eq        :: Precedence
 262 precedence_Eq         = Precedence 4
 263 precedence_LtStarGt  :: Precedence
 264 precedence_LtStarGt   = precedence_Eq
 265 precedence_Or        :: Precedence
 266 precedence_Or         = Precedence 5
 267 precedence_List_Cons :: Precedence
 268 precedence_List_Cons  = Precedence 5
 269 precedence_Xor       :: Precedence
 270 precedence_Xor        = precedence_Or
 271 precedence_And       :: Precedence
 272 precedence_And        = Precedence 6
 273 precedence_Add       :: Precedence
 274 precedence_Add        = precedence_And
 275 precedence_Sub       :: Precedence
 276 precedence_Sub        = precedence_Add
 277 precedence_Mul       :: Precedence
 278 precedence_Mul        = Precedence 7
 279 precedence_Mod       :: Precedence
 280 precedence_Mod        = precedence_Mul
 281 precedence_App       :: Precedence
 282 precedence_App        = Precedence 8
 283 precedence_Not       :: Precedence
 284 precedence_Not        = Precedence 9
 285 precedence_Neg       :: Precedence
 286 precedence_Neg        = precedence_Not
 287 precedence_Atomic    :: Precedence
 288 precedence_Atomic     = Precedence maxBound