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 (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 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 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 instance Sym_Bool (Repr_Text lam) where
  56         bool a = Repr_Text $ \_p _v ->
  57                 Text.pack (show a)
  58         not (Repr_Text x) =
  59                 Repr_Text $ \p v ->
  60                         let p' = precedence_Not in
  61                         paren p p' $ "!" <> x p' v
  62         (&&) (Repr_Text x) (Repr_Text y) =
  63                 Repr_Text $ \p v ->
  64                         let p' = precedence_And in
  65                         paren p p' $ x p' v <> " && " <> y p' v
  66         (||) (Repr_Text x) (Repr_Text y) =
  67                 Repr_Text $ \p v ->
  68                         let p' = precedence_Or in
  69                         paren p p'  $ x p' v <> " || " <> y p' v
  70         xor (Repr_Text x) (Repr_Text y) =
  71                 Repr_Text $ \p v ->
  72                         let p' = precedence_Xor in
  73                         paren p p'  $ "xor " <> x p' v <> " " <> y p' v
  74 instance Sym_Int (Repr_Text lam) where
  75         int a = Repr_Text $ \_p _v ->
  76                 Text.pack (show a)
  77         abs = repr_text_app1 "abs"
  78         negate (Repr_Text x) =
  79                 Repr_Text $ \p v ->
  80                         let p' = precedence_Neg in
  81                         paren p p' $ "-" <> x p' v
  82         (+) (Repr_Text x) (Repr_Text y) =
  83                 Repr_Text $ \p v ->
  84                         let p' = precedence_Add in
  85                         paren p p' $ x p' v <> " + " <> y p' v
  86         (-) (Repr_Text x) (Repr_Text y) =
  87                 Repr_Text $ \p v ->
  88                         let p' = precedence_Sub 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_Mul in
  93                         paren p p' $ x p' v <> " * " <> y p' v
  94         mod (Repr_Text x) (Repr_Text y) =
  95                 Repr_Text $ \p v ->
  96                         let p' = precedence_Mod in
  97                         paren p p' $ x p' v <> " % " <> y p' v
  98 instance Sym_Text (Repr_Text lam) where
  99         text a = Repr_Text $ \_p _v -> Text.pack (show a)
 100 instance Sym_Maybe (Repr_Text lam) where
 101         nothing =
 102                 Repr_Text $ \_p _v ->
 103                         "nothing"
 104         just = repr_text_app1 "just"
 105 instance Sym_Maybe_Lam lam (Repr_Text lam) where
 106         maybe = repr_text_app3 "maybe"
 107 instance Sym_If (Repr_Text lam) where
 108         if_ (Repr_Text cond) (Repr_Text ok) (Repr_Text ko) =
 109                 Repr_Text $ \p v ->
 110                         let p' = precedence_If in
 111                         paren p p' $
 112                         "if " <> cond p' v <>
 113                         " then " <> ok p' v <>
 114                         " else " <> ko p' v
 115 instance Sym_When (Repr_Text lam) where
 116         when (Repr_Text cond) (Repr_Text ok) =
 117                 Repr_Text $ \p v ->
 118                         let p' = precedence_If in
 119                         paren p p' $
 120                         "when " <> cond p' v <>
 121                         " " <> ok p' v
 122 instance Sym_Eq (Repr_Text lam) where
 123         (==) (Repr_Text x) (Repr_Text y) =
 124                 Repr_Text $ \p v ->
 125                         let p' = precedence_Eq in
 126                         paren p p' $
 127                         x p' v <> " == " <> y p' v
 128 instance Sym_Ord (Repr_Text lam) where
 129         compare (Repr_Text x) (Repr_Text y) =
 130                 Repr_Text $ \p v ->
 131                         let p' = precedence_Eq in
 132                         paren p p' $
 133                         "compare " <> x p' v <> " " <> y p' v
 134 instance Sym_List (Repr_Text lam) where
 135         list_empty = Repr_Text $ \_p _v ->
 136                 "[]"
 137         list_cons (Repr_Text x) (Repr_Text xs) =
 138                 Repr_Text $ \p v ->
 139                         let p' = precedence_List_Cons in
 140                         paren p p' $ x p' v <> ":" <> xs p' v
 141         list l = Repr_Text $ \_p v ->
 142                 let p' = precedence_Toplevel in
 143                 "[" <> Text.intercalate ", " ((\(Repr_Text a) -> a p' v) Prelude.<$> l) <> "]"
 144 instance Sym_List_Lam lam (Repr_Text lam) where
 145         list_filter = repr_text_app2 "list_filter"
 146 instance Sym_Tuple2 (Repr_Text lam) where
 147         tuple2 (Repr_Text a) (Repr_Text b) =
 148                 Repr_Text $ \_p v ->
 149                         let p' = precedence_Toplevel in
 150                         "(" <> a p' v <> ", " <> b p' v <> ")"
 151 instance Sym_Map (Repr_Text lam) where
 152         map_from_list = repr_text_app1 "map_from_list"
 153 instance Sym_Map_Lam lam (Repr_Text lam) where
 154         map_map = repr_text_app2 "map_map"
 155 instance Sym_Functor lam (Repr_Text lam) where
 156         fmap = repr_text_app2 "fmap"
 157 instance Sym_Applicative (Repr_Text lam) where
 158         pure = repr_text_app1 "pure"
 159 instance Sym_Applicative_Lam lam (Repr_Text lam) where
 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 lam (Repr_Text lam) where
 165         traverse = repr_text_app2 "traverse"
 166 instance Sym_Monad (Repr_Text lam) where
 167         return = repr_text_app1 "return"
 168 instance Sym_Monad_Lam lam (Repr_Text lam) where
 169         (>>=) (Repr_Text g) (Repr_Text ma) =
 170                 Repr_Text $ \p v ->
 171                         let p' = precedence_Bind in
 172                         paren p p' $ g p' v <> " >>= " <> ma p' v
 173 instance Sym_Either (Repr_Text lam) where
 174         right = repr_text_app1 "right"
 175         left  = repr_text_app1 "left"
 176 instance Sym_IO (Repr_Text lam) where
 177         io_hClose   = repr_text_app1 "io_hClose"
 178         io_openFile = repr_text_app2 "io_openFile"
 179 instance Sym_Foldable (Repr_Text lam) where
 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_Foldable_Lam lam (Repr_Text lam) where
 186         foldMap = repr_text_app2 "foldMap"
 187 instance Sym_Monoid (Repr_Text lam) where
 188         mempty = Repr_Text $ \_p _v -> "mempty"
 189         mappend = repr_text_app2 "mappend"
 190
 191 -- * Helpers
 192
 193 -- ** Helpers for lambda applications
 194 repr_text_app1
 195  :: Text
 196  -> Repr_Text lam a1
 197  -> Repr_Text lam h
 198 repr_text_app1 name (Repr_Text a1) =
 199         Repr_Text $ \p v ->
 200                 let p' = precedence_App in
 201                 paren p p' $ name
 202                  <> " " <> a1 p' v
 203 repr_text_app2
 204  :: Text
 205  -> Repr_Text lam a1
 206  -> Repr_Text lam a2
 207  -> Repr_Text lam h
 208 repr_text_app2 name (Repr_Text a1) (Repr_Text a2) =
 209         Repr_Text $ \p v ->
 210                 let p' = precedence_App in
 211                 paren p p' $ name
 212                  <> " " <> a1 p' v
 213                  <> " " <> a2 p' v
 214 repr_text_app3
 215  :: Text
 216  -> Repr_Text lam a1
 217  -> Repr_Text lam a2
 218  -> Repr_Text lam a3
 219  -> Repr_Text lam h
 220 repr_text_app3 name (Repr_Text a1) (Repr_Text a2) (Repr_Text a3) =
 221         Repr_Text $ \p v ->
 222                 let p' = precedence_App in
 223                 paren p p' $ name
 224                  <> " " <> a1 p' v
 225                  <> " " <> a2 p' v
 226                  <> " " <> a3 p' v
 227
 228 -- ** Helpers for 'Sym_Lambda' instances
 229 repr_text_fun
 230  :: Text
 231  -> (Repr_Text lam a2 -> Repr_Text lam a1)
 232  -> Repr_Text lam a
 233 repr_text_fun mode e =
 234         Repr_Text $ \p v ->
 235                 let p' = precedence_Lambda in
 236                 let x = "x" <> Text.pack (show v) in
 237                 paren p p' $
 238                 "\\" <> mode <> x <> " -> " <>
 239                 unRepr_Text (e (Repr_Text $ \_p _v -> x)) p' (succ v)
 240 repr_text_let
 241  :: Text
 242  -> Repr_Text lam a1
 243  -> (Repr_Text lam a3 -> Repr_Text lam a2)
 244  -> Repr_Text lam a
 245 repr_text_let mode e in_ =
 246         Repr_Text $ \p v ->
 247                 let p' = precedence_Let in
 248                 let x = "x" <> Text.pack (show v) in
 249                 paren p p' $
 250                 "let" <> mode <> " " <> x <> " = " <> unRepr_Text e p (succ v) <> " in " <>
 251                 unRepr_Text (in_ (Repr_Text $ \_p _v -> x)) p (succ v)
 252
 253 -- ** Type 'Precedence'
 254
 255 newtype Precedence = Precedence Int
 256  deriving (Eq, Ord, Show)
 257 precedence_pred :: Precedence -> Precedence
 258 precedence_pred (Precedence p) = Precedence (pred p)
 259 precedence_succ :: Precedence -> Precedence
 260 precedence_succ (Precedence p) = Precedence (succ p)
 261 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
 262 paren prec prec' x =
 263         if prec >= prec'
 264          then fromString "(" <> x <> fromString ")"
 265          else x
 266
 267 precedence_Toplevel  :: Precedence
 268 precedence_Toplevel   = Precedence 0
 269 precedence_Lambda    :: Precedence
 270 precedence_Lambda     = Precedence 1
 271 precedence_Bind      :: Precedence
 272 precedence_Bind       = precedence_Lambda
 273 precedence_If        :: Precedence
 274 precedence_If         = Precedence 2
 275 precedence_Let       :: Precedence
 276 precedence_Let        = Precedence 3
 277 precedence_Eq        :: Precedence
 278 precedence_Eq         = Precedence 4
 279 precedence_LtStarGt  :: Precedence
 280 precedence_LtStarGt   = precedence_Eq
 281 precedence_Or        :: Precedence
 282 precedence_Or         = Precedence 5
 283 precedence_List_Cons :: Precedence
 284 precedence_List_Cons  = Precedence 5
 285 precedence_Xor       :: Precedence
 286 precedence_Xor        = precedence_Or
 287 precedence_And       :: Precedence
 288 precedence_And        = Precedence 6
 289 precedence_Add       :: Precedence
 290 precedence_Add        = precedence_And
 291 precedence_Sub       :: Precedence
 292 precedence_Sub        = precedence_Add
 293 precedence_Mul       :: Precedence
 294 precedence_Mul        = Precedence 7
 295 precedence_Mod       :: Precedence
 296 precedence_Mod        = precedence_Mul
 297 precedence_App       :: Precedence
 298 precedence_App        = Precedence 8
 299 precedence_Not       :: Precedence
 300 precedence_Not        = Precedence 9
 301 precedence_Neg       :: Precedence
 302 precedence_Neg        = precedence_Not
 303 precedence_Atomic    :: Precedence
 304 precedence_Atomic     = Precedence maxBound