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 (fun:: * -> *) 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 fun h -> String
  29 string_from_expr r = unRepr_String r precedence_Toplevel 0
  30
  31 instance Show (Repr_String fun a) where
  32         show = string_from_expr
  33
  34 instance Sym_Lambda fun (Repr_String fun) where
  35         type Lambda_from_Repr (Repr_String fun) = fun
  36         app (Repr_String f) (Repr_String x) = Repr_String $ \p v ->
  37                 let p' = precedence_App in
  38                 paren p p' $
  39                 f p' v <> " " <> x p' v
  40         inline     = repr_string_fun "!"
  41         val        = repr_string_fun ""
  42         lazy       = repr_string_fun "~"
  43
  44         let_inline = repr_string_let "!"
  45         let_val    = repr_string_let ""
  46         let_lazy   = repr_string_let "~"
  47
  48 -- ** Helpers for 'Sym_Lambda' instances
  49 repr_string_fun :: String -> (Repr_String fun a2 -> Repr_String fun a1) -> Repr_String fun a
  50 repr_string_fun mode e =
  51         Repr_String $ \p v ->
  52                 let p' = precedence_Lambda in
  53                 let x = "x" <> show v in
  54                 paren p p' $
  55                 "\\" <> mode <> x <> " -> " <>
  56                 unRepr_String (e (Repr_String $ \_p _v -> x)) p' (succ v)
  57 repr_string_let
  58  :: String
  59  -> Repr_String fun a1
  60  -> (Repr_String fun a3 -> Repr_String fun a2)
  61  -> Repr_String fun a
  62 repr_string_let mode e in_ =
  63         Repr_String $ \p v ->
  64                 let p' = precedence_Let in
  65                 let x = "x" <> show v in
  66                 paren p p' $
  67                 "let" <> mode <> " " <> x <> " = " <> unRepr_String e p (succ v) <> " in " <>
  68                 unRepr_String (in_ (Repr_String $ \_p _v -> x)) p (succ v)
  69
  70 instance Sym_Bool (Repr_String fun) where
  71         bool a = Repr_String $ \_p _v -> 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 fun) where
  90         int a = Repr_String $ \_p _v -> show a
  91         neg (Repr_String x) =
  92                 Repr_String $ \p v ->
  93                         let p' = precedence_Neg in
  94                         paren p p' $ "-" <> x (precedence_succ p') v
  95         add (Repr_String x) (Repr_String y) =
  96                 Repr_String $ \p v ->
  97                         let p' = precedence_Add in
  98                         paren p p' $ x p' v <> " + " <> y p' v
  99 {-
 100 instance Sym_If Repr_String where
 101         if_
 102          (Repr_String cond)
 103          (Repr_String ok)
 104          (Repr_String ko) =
 105                 Repr_String $ \p v ->
 106                         let p' = precedence_If in
 107                         paren p p' $
 108                         "if " <> cond p' v <>
 109                         " then " <> ok p' v <>
 110                         " else " <> ko p' v
 111         when_ (Repr_String cond) (Repr_String ok) =
 112                 Repr_String $ \p v ->
 113                         let p' = precedence_If in
 114                         paren p p' $
 115                         "when " <> cond p' v <>
 116                         " " <> ok p' v
 117 -}
 118
 119 -- ** Type 'Precedence'
 120
 121 newtype Precedence = Precedence Int
 122  deriving (Eq, Ord, Show)
 123 precedence_pred :: Precedence -> Precedence
 124 precedence_pred (Precedence p) = Precedence (pred p)
 125 precedence_succ :: Precedence -> Precedence
 126 precedence_succ (Precedence p) = Precedence (succ p)
 127 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
 128 paren prec prec' x =
 129         if prec >= prec'
 130          then fromString "(" <> x <> fromString ")"
 131          else x
 132
 133 precedence_Toplevel :: Precedence
 134 precedence_Toplevel  = Precedence 0
 135 precedence_Lambda   :: Precedence
 136 precedence_Lambda    = Precedence 1
 137 precedence_Let      :: Precedence
 138 precedence_Let       = Precedence 2
 139 precedence_If       :: Precedence
 140 precedence_If        = Precedence 3
 141 precedence_Or       :: Precedence
 142 precedence_Or        = Precedence 4
 143 precedence_Add      :: Precedence
 144 precedence_Add       = precedence_Or
 145 precedence_Xor      :: Precedence
 146 precedence_Xor       = Precedence 5
 147 precedence_And      :: Precedence
 148 precedence_And       = Precedence 6
 149 precedence_App      :: Precedence
 150 precedence_App       = Precedence 7
 151 precedence_Not      :: Precedence
 152 precedence_Not       = Precedence 8
 153 precedence_Neg      :: Precedence
 154 precedence_Neg       = precedence_Not
 155 precedence_Atomic   :: Precedence
 156 precedence_Atomic    = Precedence 9