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 instance Sym_Tuple2 Repr_Text where
 149         tuple2 (Repr_Text a) (Repr_Text b) =
 150                 Repr_Text $ \_p v ->
 151                         let p' = precedence_Toplevel in
 152                         "(" <> a p' v <> ", " <> b p' v <> ")"
 153 instance Sym_Map Repr_Text where
 154         map_from_list = repr_text_app1 "map_from_list"
 155         mapWithKey    = repr_text_app2 "mapWithKey"
 156 instance Sym_Functor Repr_Text where
 157         fmap = repr_text_app2 "fmap"
 158 instance Sym_Applicative Repr_Text where
 159         pure = repr_text_app1 "pure"
 160         (<*>) (Repr_Text fg) (Repr_Text fa) =
 161                 Repr_Text $ \p v ->
 162                         let p' = precedence_LtStarGt in
 163                         paren p p' $ fg p' v <> " <*> " <> fa p' v
 164 instance Sym_Traversable Repr_Text where
 165         traverse = repr_text_app2 "traverse"
 166 instance Sym_Monad Repr_Text where
 167         return = repr_text_app1 "return"
 168         (>>=) (Repr_Text g) (Repr_Text ma) =
 169                 Repr_Text $ \p v ->
 170                         let p' = precedence_Bind in
 171                         paren p p' $ g p' v <> " >>= " <> ma p' v
 172 instance Sym_Either Repr_Text where
 173         right = repr_text_app1 "right"
 174         left  = repr_text_app1 "left"
 175 instance Sym_IO Repr_Text where
 176         io_hClose   = repr_text_app1 "io_hClose"
 177         io_openFile = repr_text_app2 "io_openFile"
 178 instance Sym_Foldable Repr_Text where
 179         foldMap = repr_text_app2 "foldMap"
 180         null    = repr_text_app1 "null"
 181         length  = repr_text_app1 "length"
 182         minimum = repr_text_app1 "minimum"
 183         maximum = repr_text_app1 "maximum"
 184         elem    = repr_text_app2 "elem"
 185 instance Sym_Monoid Repr_Text where
 186         mempty = Repr_Text $ \_p _v -> "mempty"
 187         mappend = repr_text_app2 "mappend"
 188
 189 -- * Helpers
 190
 191 -- ** Helpers for lambda applications
 192 repr_text_app1
 193  :: Text
 194  -> Repr_Text a1
 195  -> Repr_Text h
 196 repr_text_app1 name (Repr_Text a1) =
 197         Repr_Text $ \p v ->
 198                 let p' = precedence_App in
 199                 paren p p' $ name
 200                  <> " " <> a1 p' v
 201 repr_text_app2
 202  :: Text
 203  -> Repr_Text a1
 204  -> Repr_Text a2
 205  -> Repr_Text h
 206 repr_text_app2 name (Repr_Text a1) (Repr_Text a2) =
 207         Repr_Text $ \p v ->
 208                 let p' = precedence_App in
 209                 paren p p' $ name
 210                  <> " " <> a1 p' v
 211                  <> " " <> a2 p' v
 212 repr_text_app3
 213  :: Text
 214  -> Repr_Text a1
 215  -> Repr_Text a2
 216  -> Repr_Text a3
 217  -> Repr_Text h
 218 repr_text_app3 name (Repr_Text a1) (Repr_Text a2) (Repr_Text a3) =
 219         Repr_Text $ \p v ->
 220                 let p' = precedence_App in
 221                 paren p p' $ name
 222                  <> " " <> a1 p' v
 223                  <> " " <> a2 p' v
 224                  <> " " <> a3 p' v
 225
 226 -- ** Type 'Precedence'
 227
 228 newtype Precedence = Precedence Int
 229  deriving (Eq, Ord, Show)
 230 precedence_pred :: Precedence -> Precedence
 231 precedence_pred (Precedence p) = Precedence (pred p)
 232 precedence_succ :: Precedence -> Precedence
 233 precedence_succ (Precedence p) = Precedence (succ p)
 234 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
 235 paren prec prec' x =
 236         if prec >= prec'
 237          then fromString "(" <> x <> fromString ")"
 238          else x
 239
 240 precedence_Toplevel  :: Precedence
 241 precedence_Toplevel   = Precedence 0
 242 precedence_Lambda    :: Precedence
 243 precedence_Lambda     = Precedence 1
 244 precedence_Bind      :: Precedence
 245 precedence_Bind       = precedence_Lambda
 246 precedence_If        :: Precedence
 247 precedence_If         = Precedence 2
 248 precedence_Let       :: Precedence
 249 precedence_Let        = Precedence 3
 250 precedence_Eq        :: Precedence
 251 precedence_Eq         = Precedence 4
 252 precedence_LtStarGt  :: Precedence
 253 precedence_LtStarGt   = precedence_Eq
 254 precedence_Or        :: Precedence
 255 precedence_Or         = Precedence 5
 256 precedence_List_Cons :: Precedence
 257 precedence_List_Cons  = Precedence 5
 258 precedence_Xor       :: Precedence
 259 precedence_Xor        = precedence_Or
 260 precedence_And       :: Precedence
 261 precedence_And        = Precedence 6
 262 precedence_Add       :: Precedence
 263 precedence_Add        = precedence_And
 264 precedence_Sub       :: Precedence
 265 precedence_Sub        = precedence_Add
 266 precedence_Mul       :: Precedence
 267 precedence_Mul        = Precedence 7
 268 precedence_Mod       :: Precedence
 269 precedence_Mod        = precedence_Mul
 270 precedence_App       :: Precedence
 271 precedence_App        = Precedence 8
 272 precedence_Not       :: Precedence
 273 precedence_Not        = Precedence 9
 274 precedence_Neg       :: Precedence
 275 precedence_Neg        = precedence_Not
 276 precedence_Atomic    :: Precedence
 277 precedence_Atomic     = Precedence maxBound