TFHOE/Repr/String.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 module TFHOE.Repr.String where
   6
   7 -- import Data.Functor.Identity (Identity)
   8 import Data.Monoid ((<>))
   9 import Data.String (IsString(..))
  10
  11 import TFHOE.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 Expr_Fun fun (Repr_String fun) where
  37         type Fun_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 -- ** Instance 'Fun' helpers
  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_Fun 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 Expr_Bool (Repr_String fun) where
  73         bool a = Repr_String $ \_p _v -> show a
  74         neg (Repr_String x) =
  75                 Repr_String $ \p v ->
  76                         let p' = precedence_Neg 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 Expr_Int (Repr_String fun) where
  92         int a = Repr_String $ \_p _v -> show a
  93         add (Repr_String x) (Repr_String y) =
  94                 Repr_String $ \p v ->
  95                         let p' = precedence_Add in
  96                         paren p p' $ x p' v <> " + " <> y p' v
  97 {-
  98 instance Expr_If Repr_String where
  99         if_
 100          (Repr_String cond)
 101          (Repr_String ok)
 102          (Repr_String ko) =
 103                 Repr_String $ \p v ->
 104                         let p' = precedence_If in
 105                         paren p p' $
 106                         "if " <> cond p' v <>
 107                         " then " <> ok p' v <>
 108                         " else " <> ko p' v
 109         when_ (Repr_String cond) (Repr_String ok) =
 110                 Repr_String $ \p v ->
 111                         let p' = precedence_If in
 112                         paren p p' $
 113                         "when " <> cond p' v <>
 114                         " " <> ok p' v
 115 -}
 116
 117 -- ** Type 'Precedence'
 118
 119 newtype Precedence = Precedence Int
 120  deriving (Eq, Ord, Show)
 121 precedence_pred :: Precedence -> Precedence
 122 precedence_pred (Precedence p) = Precedence (pred p)
 123 precedence_succ :: Precedence -> Precedence
 124 precedence_succ (Precedence p) = Precedence (succ p)
 125 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
 126 paren prec prec' x =
 127         if prec >= prec'
 128          then fromString "(" <> x <> fromString ")"
 129          else x
 130
 131 precedence_Toplevel :: Precedence
 132 precedence_Toplevel  = Precedence 0
 133 precedence_Fun      :: Precedence
 134 precedence_Fun       = Precedence 1
 135 precedence_Let      :: Precedence
 136 precedence_Let       = Precedence 2
 137 precedence_If       :: Precedence
 138 precedence_If        = Precedence 3
 139 precedence_Or       :: Precedence
 140 precedence_Or        = Precedence 4
 141 precedence_Add      :: Precedence
 142 precedence_Add       = precedence_Or
 143 precedence_Xor      :: Precedence
 144 precedence_Xor       = Precedence 5
 145 precedence_And      :: Precedence
 146 precedence_And       = Precedence 6
 147 precedence_App      :: Precedence
 148 precedence_App       = Precedence 7
 149 precedence_Neg      :: Precedence
 150 precedence_Neg       = Precedence 8
 151 precedence_Atomic   :: Precedence
 152 precedence_Atomic    = Precedence 9