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