Language/LOL/Symantic/Repr/String.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 -- | Interpreter to serialize an expression into a 'String'.
   6 module Language.LOL.Symantic.Repr.String where
   7
   8 import Data.Monoid ((<>))
   9 import Data.String (IsString(..))
  10
  11 import Language.LOL.Symantic.Expr
  12
  13 -- * Type 'Repr_String'
  14
  15 -- | Interpreter's data.
  16 newtype Repr_String (lam:: * -> *) h
  17  =      Repr_String
  18  {    unRepr_String
  19         -- Inherited attributes:
  20         :: Precedence
  21         -> Repr_String_Lambda_Depth
  22         -- Synthetised attributes:
  23         -> String
  24  }
  25 type Repr_String_Lambda_Depth = Int
  26
  27 -- | Interpreter.
  28 string_from_expr :: Repr_String lam h -> String
  29 string_from_expr r = unRepr_String r precedence_Toplevel 0
  30
  31 instance Show (Repr_String lam a) where
  32         show = string_from_expr
  33 instance Sym_Lambda lam (Repr_String lam) where
  34         type Lambda_from_Repr (Repr_String lam) = lam
  35         app (Repr_String f) (Repr_String x) = Repr_String $ \p v ->
  36                 let p' = precedence_App in
  37                 paren p p' $
  38                 f p' v <> " " <> x p' v
  39         inline     = repr_string_fun "!"
  40         val        = repr_string_fun ""
  41         lazy       = repr_string_fun "~"
  42
  43         let_inline = repr_string_let "!"
  44         let_val    = repr_string_let ""
  45         let_lazy   = repr_string_let "~"
  46
  47 -- ** Helpers for 'Sym_Lambda' instances
  48 repr_string_fun :: String -> (Repr_String lam a2 -> Repr_String lam a1) -> Repr_String lam a
  49 repr_string_fun mode e =
  50         Repr_String $ \p v ->
  51                 let p' = precedence_Lambda in
  52                 let x = "x" <> show v in
  53                 paren p p' $
  54                 "\\" <> mode <> x <> " -> " <>
  55                 unRepr_String (e (Repr_String $ \_p _v -> x)) p' (succ v)
  56 repr_string_let
  57  :: String
  58  -> Repr_String lam a1
  59  -> (Repr_String lam a3 -> Repr_String lam a2)
  60  -> Repr_String lam a
  61 repr_string_let mode e in_ =
  62         Repr_String $ \p v ->
  63                 let p' = precedence_Let in
  64                 let x = "x" <> show v in
  65                 paren p p' $
  66                 "let" <> mode <> " " <> x <> " = " <> unRepr_String e p (succ v) <> " in " <>
  67                 unRepr_String (in_ (Repr_String $ \_p _v -> x)) p (succ v)
  68
  69 instance Sym_Bool (Repr_String lam) where
  70         bool a = Repr_String $ \_p _v ->
  71                 show a
  72         not (Repr_String x) =
  73                 Repr_String $ \p v ->
  74                         let p' = precedence_Not in
  75                         paren p p' $ "!" <> x (precedence_succ p') v
  76         and (Repr_String x) (Repr_String y) =
  77                 Repr_String $ \p v ->
  78                         let p' = precedence_And in
  79                         paren p p' $ x p' v <> " & " <> y p' v
  80         or (Repr_String x) (Repr_String y) =
  81                 Repr_String $ \p v ->
  82                         let p' = precedence_Or in
  83                         paren p p'  $ x p' v <> " | " <> y p' v
  84         {-xor (Repr_String x) (Repr_String y) =
  85                 Repr_String $ \p v ->
  86                         let p' = precedence_Xor in
  87                         paren p p'  $ x p' v <> " * " <> y p' v
  88         -}
  89 instance Sym_Int (Repr_String lam) where
  90         int a = Repr_String $ \_p _v ->
  91                 show a
  92         neg (Repr_String x) =
  93                 Repr_String $ \p v ->
  94                         let p' = precedence_Neg in
  95                         paren p p' $ "-" <> x (precedence_succ p') v
  96         add (Repr_String x) (Repr_String y) =
  97                 Repr_String $ \p v ->
  98                         let p' = precedence_Add in
  99                         paren p p' $ x p' v <> " + " <> y p' v
 100 instance Sym_Maybe lam (Repr_String lam) where
 101         maybe (Repr_String n) (Repr_String j) (Repr_String m) =
 102                 Repr_String $ \p v ->
 103                         let p' = precedence_Lambda in
 104                         paren p p' $ "maybe"
 105                                  <> " " <> n (precedence_succ p') v
 106                                  <> " " <> j (precedence_succ p') v
 107                                  <> " " <> m (precedence_succ p') v
 108 instance Sym_Maybe_Cons (Repr_String lam) where
 109         nothing =
 110                 Repr_String $ \_p _v ->
 111                         "nothing"
 112         just (Repr_String a) =
 113                 Repr_String $ \p v ->
 114                         let p' = precedence_Lambda in
 115                         paren p p' $ "just "
 116                                  <> a (precedence_succ p') v
 117 instance Sym_If (Repr_String lam) where
 118         if_
 119          (Repr_String cond)
 120          (Repr_String ok)
 121          (Repr_String ko) =
 122                 Repr_String $ \p v ->
 123                         let p' = precedence_If in
 124                         paren p p' $
 125                         "if " <> cond p' v <>
 126                         " then " <> ok p' v <>
 127                         " else " <> ko p' v
 128         when_ (Repr_String cond) (Repr_String ok) =
 129                 Repr_String $ \p v ->
 130                         let p' = precedence_If in
 131                         paren p p' $
 132                         "when " <> cond p' v <>
 133                         " " <> ok p' v
 134
 135 -- ** Type 'Precedence'
 136
 137 newtype Precedence = Precedence Int
 138  deriving (Eq, Ord, Show)
 139 precedence_pred :: Precedence -> Precedence
 140 precedence_pred (Precedence p) = Precedence (pred p)
 141 precedence_succ :: Precedence -> Precedence
 142 precedence_succ (Precedence p) = Precedence (succ p)
 143 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
 144 paren prec prec' x =
 145         if prec >= prec'
 146          then fromString "(" <> x <> fromString ")"
 147          else x
 148
 149 precedence_Toplevel :: Precedence
 150 precedence_Toplevel  = Precedence 0
 151 precedence_Lambda   :: Precedence
 152 precedence_Lambda    = Precedence 1
 153 precedence_Let      :: Precedence
 154 precedence_Let       = Precedence 2
 155 precedence_If       :: Precedence
 156 precedence_If        = Precedence 3
 157 precedence_Or       :: Precedence
 158 precedence_Or        = Precedence 4
 159 precedence_Add      :: Precedence
 160 precedence_Add       = precedence_Or
 161 precedence_Xor      :: Precedence
 162 precedence_Xor       = Precedence 5
 163 precedence_And      :: Precedence
 164 precedence_And       = Precedence 6
 165 precedence_App      :: Precedence
 166 precedence_App       = Precedence 7
 167 precedence_Not      :: Precedence
 168 precedence_Not       = Precedence 8
 169 precedence_Neg      :: Precedence
 170 precedence_Neg       = precedence_Not
 171 precedence_Atomic   :: Precedence
 172 precedence_Atomic    = Precedence 9