Language/LOL/Symantic/Repr/String.hs

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